Hardcopy stuff (includes files from HARDCOPY PR)
This commit is contained in:
rmkaplan
@@ -1,14 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "30-Jul-2025 18:01:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>PDFSTREAM.;68 15635
|
||||
(FILECREATED "23-Aug-2025 10:53:33" {WMEDLEY}<library>PDFSTREAM.;70 15659
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS SEE-PDF)
|
||||
:CHANGES-TO (FNS PDF.FONTSAVAILABLE)
|
||||
|
||||
:PREVIOUS-DATE "16-Jun-2025 00:52:44"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>PDFSTREAM.;67)
|
||||
:PREVIOUS-DATE "30-Jul-2025 18:01:04" {WMEDLEY}<library>PDFSTREAM.;68)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT PDFSTREAMCOMS)
|
||||
@@ -129,12 +127,11 @@
|
||||
(CLOSEF TSTREAM])
|
||||
|
||||
(PDF.FONTSAVAILABLE
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 16-Jun-2025 00:46 by rmk")
|
||||
(* ; "Edited 12-Jan-88 13:04 by Matt Heffron")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(POSTSCRIPT.FONTSAVAILABLE FAMILY SIZE FACE ROTATION 'PDF])
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 23-Aug-2025 10:53 by rmk")
|
||||
(* ; "Edited 16-Jun-2025 00:46 by rmk")
|
||||
(LET ((FA (FONTSAVAILABLE FONTSPEC NIL NIL NIL 'POSTSCRIPT T)))
|
||||
(for FS in FA do (replace (FONTSPEC FSDEVICE) of FS with 'PDF))
|
||||
FA])
|
||||
)
|
||||
|
||||
(FONTPROFILE.ADDDEVICE 'PDF 'POSTSCRIPT)
|
||||
@@ -308,8 +305,8 @@
|
||||
thereis (ShellWhich (CAR TEMPLATE])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3492 6433 (PDFFILEP 3502 . 4416) (PDF.HARDCOPYW 4418 . 5016) (PDF.TEXT 5018 . 5735) (
|
||||
PDF.TEDIT 5737 . 6104) (PDF.FONTSAVAILABLE 6106 . 6431)) (6873 14518 (OPEN-PDF-STREAM 6883 . 9604) (
|
||||
CLOSE-PDF-STREAM 9606 . 10893) (PS-TO-PDF 10895 . 14516)) (14519 15277 (SEE-PDF 14529 . 15275)) (15328
|
||||
15612 (PDFCONVERTER 15338 . 15610)))))
|
||||
(FILEMAP (NIL (3421 6457 (PDFFILEP 3431 . 4345) (PDF.HARDCOPYW 4347 . 4945) (PDF.TEXT 4947 . 5664) (
|
||||
PDF.TEDIT 5666 . 6033) (PDF.FONTSAVAILABLE 6035 . 6455)) (6897 14542 (OPEN-PDF-STREAM 6907 . 9628) (
|
||||
CLOSE-PDF-STREAM 9630 . 10917) (PS-TO-PDF 10919 . 14540)) (14543 15301 (SEE-PDF 14553 . 15299)) (15352
|
||||
15636 (PDFCONVERTER 15362 . 15634)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "14-Jul-2025 22:21:34" {WMEDLEY}<library>POSTSCRIPTSTREAM.;24 258986
|
||||
(FILECREATED "10-Sep-2025 14:51:53" {WMEDLEY}<library>POSTSCRIPTSTREAM.;42 258973
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \DSPFONT.PSC)
|
||||
:CHANGES-TO (FNS POSTSCRIPTFILEP POSTSCRIPT.INIT)
|
||||
|
||||
:PREVIOUS-DATE "16-Jun-2025 00:04:32" {WMEDLEY}<library>POSTSCRIPTSTREAM.;23)
|
||||
:PREVIOUS-DATE " 8-Sep-2025 09:51:34" {WMEDLEY}<library>POSTSCRIPTSTREAM.;39)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS)
|
||||
@@ -43,10 +43,6 @@
|
||||
PSCFONTFROMCACHE.COERCEFILE PSCFONT.WRITEFONT READ-AFM-FILE CONVERT-AFM-FILES
|
||||
POSTSCRIPT.GETFONTID POSTSCRIPT.FONTCREATE \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS
|
||||
POSTSCRIPT.FONTSAVAILABLE POSTSCRIPT.FONTEXISTS?)
|
||||
(COMS
|
||||
(* ;; "Until macro in FONT is exported")
|
||||
|
||||
(MACROS \FSETCHARWIDTH))
|
||||
(FNS OPENPOSTSCRIPTSTREAM CLOSEPOSTSCRIPTSTREAM)
|
||||
(INITVARS (*POSTSCRIPT-FILE-TYPE* 'BINARY))
|
||||
(FNS POSTSCRIPT.HARDCOPYW POSTSCRIPT.TEDIT POSTSCRIPT.TEXT POSTSCRIPTFILEP MAKEEPSFILE)
|
||||
@@ -131,6 +127,7 @@
|
||||
(CONSTANTS (GOLDEN.RATIO 1.618034)
|
||||
(\PS.SCALE0 100)
|
||||
(\PS.TEMPARRAYLEN 20))
|
||||
(GLOBALVARS POSTSCRIPTFONTEXTENSIONS POSTSCRIPTFONTDIRECTORIES)
|
||||
(INITVARS (POSTSCRIPT.BITMAP.SCALE 1)
|
||||
(POSTSCRIPT.EOL 'CR)
|
||||
(POSTSCRIPT.IMAGESIZEFACTOR 1)
|
||||
@@ -142,6 +139,21 @@
|
||||
'MAIKO)
|
||||
"{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/")
|
||||
(T "{DSK}<LISPFILES>POSTSCRIPT>"]
|
||||
(POSTSCRIPTFONTEXTENSIONS '(PSCFONT PF PSC))
|
||||
[POSTSCRIPTFONTCOERCIONS '((HELVETICA (HELVETICA 1))
|
||||
(HELVETICAD (HELVETICA 1))
|
||||
(TIMESROMAN (TIMES 1))
|
||||
(TIMESROMAND (TIMES 1))
|
||||
(COURIER (COURIER 1))
|
||||
(GACHA (COURIER 1))
|
||||
(CLASSIC (NEWCENTURYSCHLBK 1))
|
||||
(MODERN (HELVETICA 1))
|
||||
(CREAM (HELVETICA 1))
|
||||
(TERMINAL (COURIER 1))
|
||||
(LOGO (HELVETICA 1))
|
||||
(OPTIMA (PALATINO 1))
|
||||
(TITAN (COURIER 1))
|
||||
(* (* 1]
|
||||
(\POSTSCRIPT.MAX.WILD.FONTSIZE 72))
|
||||
[COMS (FNS POSTSCRIPTSEND)
|
||||
(ADDVARS (PRINTERTYPES ((POSTSCRIPT)
|
||||
@@ -377,7 +389,9 @@
|
||||
(DEFINEQ
|
||||
|
||||
(POSTSCRIPT.INIT
|
||||
[LAMBDA NIL (* ; "Edited 14-May-2018 10:48 by rmk:")
|
||||
[LAMBDA NIL (* ; "Edited 9-Sep-2025 21:57 by rmk")
|
||||
(* ; "Edited 22-Aug-2025 21:34 by rmk")
|
||||
(* ; "Edited 14-May-2018 10:48 by rmk:")
|
||||
(* ; "Edited 4-Feb-93 21:08 by jds")
|
||||
(DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE))
|
||||
|
||||
@@ -385,9 +399,8 @@
|
||||
|
||||
[MAPC
|
||||
[CL:REMOVE-DUPLICATES (NCONC (for FD in FONTDEFS
|
||||
join (for FP in (CDR (ASSOC 'FONTPROFILE
|
||||
(CDR FD)))
|
||||
collect (CAR FP)))
|
||||
join (for FP in (CDR (ASSOC 'FONTPROFILE (CDR FD)))
|
||||
collect (CAR FP)))
|
||||
'(FONT7 FONT6 FONT5 FONT4 FONT3 FONT2 FONT1 BOLDFONT LITTLEFONT
|
||||
BIGFONT PRETTYCOMFONT COMMENTFONT USERFONT SYSTEMFONT
|
||||
CLISPFONT LAMBDAFONT CHANGEFONT DEFAULTFONT]
|
||||
@@ -395,41 +408,35 @@
|
||||
(LET
|
||||
(COPYFD OLDPSCFD)
|
||||
(if (BOUNDP CLASS)
|
||||
then
|
||||
(SETQ CLASS (EVALV CLASS))
|
||||
(if (TYPEP CLASS 'FONTCLASS)
|
||||
then (SETQ COPYFD (OR (fetch (FONTCLASS INTERPRESSFD) of CLASS)
|
||||
(fetch (FONTCLASS PRESSFD) of CLASS)
|
||||
(fetch (FONTCLASS DISPLAYFD) of CLASS)))
|
||||
(if (SETQ OLDPSCFD (ASSOC 'POSTSCRIPT (fetch (FONTCLASS
|
||||
OTHERFDS)
|
||||
then (SETQ CLASS (EVALV CLASS))
|
||||
(if (TYPEP CLASS 'FONTCLASS)
|
||||
then (SETQ COPYFD (OR (fetch (FONTCLASS INTERPRESSFD) of CLASS)
|
||||
(fetch (FONTCLASS DISPLAYFD) of CLASS)))
|
||||
(if (SETQ OLDPSCFD (ASSOC 'POSTSCRIPT (fetch (FONTCLASS OTHERFDS)
|
||||
of CLASS)))
|
||||
then [if (NOT (CDR OLDPSCFD))
|
||||
then [if (NOT (CDR OLDPSCFD))
|
||||
then (RPLACD OLDPSCFD (if (LISTP COPYFD)
|
||||
then COPYFD
|
||||
else (FONTUNPARSE
|
||||
COPYFD]
|
||||
else (push (fetch (FONTCLASS OTHERFDS) of CLASS)
|
||||
(CONS 'POSTSCRIPT (if (LISTP COPYFD)
|
||||
then COPYFD
|
||||
else (FONTUNPARSE COPYFD]
|
||||
then COPYFD
|
||||
else (FONTUNPARSE COPYFD]
|
||||
else (push (fetch (FONTCLASS OTHERFDS) of CLASS)
|
||||
(CONS 'POSTSCRIPT (if (LISTP COPYFD)
|
||||
then COPYFD
|
||||
else (FONTUNPARSE COPYFD]
|
||||
[FOR FD IN FONTDEFS
|
||||
DO (FOR FP IN (CDR (ASSOC 'FONTPROFILE (CDR FD)))
|
||||
DO (COND
|
||||
((ASSOC 'POSTSCRIPT (CL:NTHCDR 5 FP))
|
||||
DO (COND
|
||||
((ASSOC 'POSTSCRIPT (CL:NTHCDR 5 FP))
|
||||
|
||||
(* ;; "There's already a postscript spec, so leave it be.")
|
||||
(* ;; "There's already a postscript spec, so leave it be.")
|
||||
|
||||
)
|
||||
(T (NCONC1 FP `(POSTSCRIPT ,(OR (CL:FIFTH FP)
|
||||
(CL:FOURTH FP)
|
||||
(CL:THIRD FP]
|
||||
)
|
||||
(T (NCONC1 FP `(POSTSCRIPT ,(OR (CL:FIFTH FP)
|
||||
(CL:FOURTH FP)
|
||||
(CL:THIRD FP]
|
||||
|
||||
(* ;; "Eliminate any existing postscript fonts, to start with a clean slate if reinitializing.")
|
||||
|
||||
(FOR FD IN (FONTSAVAILABLE '* '* '* '* 'POSTSCRIPT)
|
||||
DO (APPLY (FUNCTION SETFONTDESCRIPTOR)
|
||||
FD))
|
||||
(FLUSHFONTSINCORE '* '* '* '* 'POSTSCRIPT)
|
||||
(SETQ POSTSCRIPTFONTCACHE NIL)
|
||||
(SETQ \POSTSCRIPT.CHARTYPE (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT T))
|
||||
|
||||
@@ -437,7 +444,7 @@
|
||||
|
||||
(for x from (CHARCODE SP) to 126 unless (FMEMB x (CHARCODE (%( %) \)))
|
||||
do (CL:SETF (CL:AREF \POSTSCRIPT.CHARTYPE x)
|
||||
NIL))
|
||||
NIL))
|
||||
|
||||
(* ;; "RMK: Maybe the following is equivalent to alot of the stuff above??")
|
||||
|
||||
@@ -616,7 +623,8 @@
|
||||
PF])
|
||||
|
||||
(PSCFONT.SPELLFILE
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 15-Jun-2025 23:31 by rmk")
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 16-Aug-2025 23:50 by rmk")
|
||||
(* ; "Edited 15-Jun-2025 23:31 by rmk")
|
||||
(* ; "Edited 5-Oct-93 22:15 by rmk:")
|
||||
(* ; "Edited 5-Oct-92 15:23 by jds")
|
||||
|
||||
@@ -626,7 +634,7 @@
|
||||
(CL:WHEN POSTSCRIPTFONTDIRECTORIES
|
||||
(\FINDFONTFILE (OR (CDR (FASSOC FAMILY POSTSCRIPT.FONT.ALIST))
|
||||
FAMILY)
|
||||
SIZE FACE 0 DEVICE 0 POSTSCRIPTFONTDIRECTORIES '(PSCFONT PF PSC)))])
|
||||
SIZE FACE 0 DEVICE 0 POSTSCRIPTFONTDIRECTORIES POSTSCRIPTFONTEXTENSIONS))])
|
||||
|
||||
(PSCFONT.COERCEFILE
|
||||
[LAMBDA (FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE)
|
||||
@@ -881,198 +889,203 @@
|
||||
FONTID])
|
||||
|
||||
(POSTSCRIPT.FONTCREATE
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 15-Jun-2025 23:40 by rmk")
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 7-Sep-2025 23:44 by rmk")
|
||||
(* ; "Edited 30-Aug-2025 23:24 by rmk")
|
||||
(* ; "Edited 21-Aug-2025 18:21 by rmk")
|
||||
(* ; "Edited 15-Jun-2025 23:40 by rmk")
|
||||
(* ; "Edited 29-Oct-93 16:39 by rmk:")
|
||||
(* ; "Edited 3-Feb-93 17:22 by jds")
|
||||
(LET (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS PSCWIDTHSBLOCK WIDTHSBLOCK FD
|
||||
FACECHANGED (WEIGHT (CAR FACE))
|
||||
(SLOPE (CADR FACE))
|
||||
(EXPANSION (CADDR FACE)))
|
||||
(LET* (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS PSCWIDTHSBLOCK WIDTHSBLOCK FD
|
||||
FACECHANGED FAMILY SIZE FACE ROTATION DEVICE (WEIGHT (CAR FACE))
|
||||
(SLOPE (CADR FACE))
|
||||
(EXPANSION (CADDR FACE)))
|
||||
(SPREADFONTSPEC FONTSPEC)
|
||||
|
||||
(* ;;
|
||||
(* ;;
|
||||
"Ignore rotations, it is **MUCH** easier to rotate the Postscript stream user space coordinates.")
|
||||
|
||||
[COND
|
||||
[(EQ SIZE 1)
|
||||
[COND
|
||||
[(EQ SIZE 1)
|
||||
|
||||
(* ;; "Since a 1 point font is ridiculously small, and it is the standard size for Postscript font info, a 1 point font is presumed to be the unit size Postscript font info")
|
||||
(* ;; "Since a 1 point font is ridiculously small, and it is the standard size for Postscript font info, a 1 point font is presumed to be the unit size Postscript font info")
|
||||
|
||||
(COND
|
||||
((SETQ PSCFD (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
|
||||
(COND
|
||||
((SETQ PSCFD (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
|
||||
|
||||
(* ;; "Check in-core cache for exact match first")
|
||||
(* ;; "Check in-core cache for exact match first")
|
||||
|
||||
(SETQ FACECHANGED NIL))
|
||||
((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
|
||||
(SETQ FACECHANGED NIL))
|
||||
((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
|
||||
|
||||
(* ;; "Check file for exact match next")
|
||||
(* ;; "Check file for exact match next")
|
||||
|
||||
(SETQ PSCFD (PSCFONT.READFONT FULLNAME))
|
||||
(SETQ FACECHANGED NIL))
|
||||
((SETQ PSCFD (PSCFONTFROMCACHE.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION
|
||||
DEVICE))
|
||||
(SETQ PSCFD (PSCFONT.READFONT FULLNAME))
|
||||
(SETQ FACECHANGED NIL))
|
||||
((SETQ PSCFD (PSCFONTFROMCACHE.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION
|
||||
ROTATION DEVICE))
|
||||
|
||||
(* ;; "Then check cache for coerced match")
|
||||
(* ;; "Then check cache for coerced match")
|
||||
|
||||
(SETQ FACECHANGED T))
|
||||
((SETQ FULLNAME (PSCFONT.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION
|
||||
DEVICE))
|
||||
(SETQ FACECHANGED T))
|
||||
((SETQ FULLNAME (PSCFONT.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION
|
||||
DEVICE))
|
||||
|
||||
(* ;; "Check file for coerced match")
|
||||
(* ;; "Check file for coerced match")
|
||||
|
||||
(SETQ PSCFD (PSCFONT.READFONT FULLNAME))
|
||||
(SETQ FACECHANGED T)))
|
||||
(COND
|
||||
(PSCFD (SETQ ASCENT (FIXR (TIMES (fetch (PSCFONT ASCENT) of PSCFD)
|
||||
0.1)))
|
||||
(SETQ DESCENT (FIXR (TIMES (fetch (PSCFONT DESCENT) of PSCFD)
|
||||
(SETQ PSCFD (PSCFONT.READFONT FULLNAME))
|
||||
(SETQ FACECHANGED T)))
|
||||
(COND
|
||||
(PSCFD (SETQ ASCENT (FIXR (TIMES (fetch (PSCFONT ASCENT) of PSCFD)
|
||||
0.1)))
|
||||
(COND
|
||||
(FACECHANGED (replace (PSCFONT IL-FONTID) of PSCFD
|
||||
with (POSTSCRIPT.GETFONTID (fetch (PSCFONT FID)
|
||||
of PSCFD)
|
||||
WEIGHT SLOPE EXPANSION]
|
||||
((SETQ UNITFONT (FONTCREATE FAMILY 1 FACE ROTATION DEVICE T))
|
||||
(SETQ PSCFD (LISTGET (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of UNITFONT)
|
||||
'PSCFONT))
|
||||
|
||||
(* ;; "Scale the ASCENT and DESCENT")
|
||||
|
||||
(SETQ ASCENT (FIXR (TIMES SIZE (fetch (PSCFONT ASCENT) of PSCFD)
|
||||
0.1)))
|
||||
(SETQ DESCENT (FIXR (TIMES SIZE (fetch (PSCFONT DESCENT) of PSCFD)
|
||||
0.1)))
|
||||
(SETQ SCALEFONTP T))
|
||||
(T
|
||||
(* ;; "Here for fonts that only come in specific sizes. Their info is not scaled like built-in Postscript fonts, it is already correct for this pointsize.")
|
||||
|
||||
(COND
|
||||
([SETQ PSCFD (COND
|
||||
((PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
|
||||
((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE
|
||||
))
|
||||
(PSCFONT.READFONT FULLNAME]
|
||||
(SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD))
|
||||
(SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD))
|
||||
(SETQ SCALEFONTP NIL]
|
||||
(COND
|
||||
(PSCFD
|
||||
(* ;; "Set up the Charset descriptions and Widths vectors for character set 0:")
|
||||
|
||||
(SETQ FD
|
||||
(create FONTDESCRIPTOR
|
||||
OTHERDEVICEFONTPROPS _ (LIST 'PSCFONT PSCFD)
|
||||
FONTSCALE _ 100
|
||||
FONTDEVICE _ DEVICE
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ SIZE
|
||||
FONTFACE _ FACE
|
||||
ROTATION _ 0
|
||||
\SFHeight _ (IPLUS ASCENT DESCENT)
|
||||
\SFAscent _ ASCENT
|
||||
\SFDescent _ DESCENT))
|
||||
(SETQ WIDTHSBLOCK (fetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO 0 FD)))
|
||||
(SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD))
|
||||
[COND
|
||||
[SCALEFONTP (for CH from 0 to 255
|
||||
do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE (ELT FIXPWIDTHS
|
||||
CH)
|
||||
0.1]
|
||||
(T (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH (ELT FIXPWIDTHS CH]
|
||||
(SETQ PSCWIDTHSBLOCK (\CREATECSINFOELEMENT))
|
||||
|
||||
(* ;; "PSCWIDTHSBLOCK preserves the scaled widths from the original postscript metrics, not the NS mapping of them, which goes into WIDTHSBLOCK.")
|
||||
|
||||
(for CH from 0 to 255 do (\FSETWIDTH PSCWIDTHSBLOCK CH (\FGETWIDTH WIDTHSBLOCK CH)
|
||||
))
|
||||
[LET [(TMP (COND
|
||||
(FULLNAME (\FONTINFOFROMFILENAME FULLNAME DEVICE))
|
||||
(UNITFONT (fetch FONTDEVICESPEC of UNITFONT]
|
||||
|
||||
(* ;; "If face got coerced (possibly in recursive call for unit font) then set FONTDEVICESPEC to describe what we really got")
|
||||
|
||||
(SETQ DESCENT (FIXR (TIMES (fetch (PSCFONT DESCENT) of PSCFD)
|
||||
0.1)))
|
||||
(COND
|
||||
((AND TMP (NEQ FAMILY (CAR TMP)))
|
||||
(replace FONTDEVICESPEC of FD with (LIST (CAR TMP)
|
||||
SIZE
|
||||
(COPY FACE)
|
||||
0 DEVICE]
|
||||
[LET ((SYMWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'SYMBOL FD ROTATION DEVICE)
|
||||
)
|
||||
(DINGWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'ZAPFDINGBATS FD ROTATION
|
||||
DEVICE)))
|
||||
(FACECHANGED (replace (PSCFONT IL-FONTID) of PSCFD
|
||||
with (POSTSCRIPT.GETFONTID (fetch (PSCFONT FID)
|
||||
of PSCFD)
|
||||
WEIGHT SLOPE EXPANSION]
|
||||
((SETQ UNITFONT (FONTCREATE FAMILY 1 FACE ROTATION DEVICE T))
|
||||
(SETQ PSCFD (LISTGET (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of UNITFONT)
|
||||
'PSCFONT))
|
||||
|
||||
(* ;;
|
||||
(* ;; "Scale the ASCENT and DESCENT")
|
||||
|
||||
(SETQ ASCENT (FIXR (TIMES SIZE (fetch (PSCFONT ASCENT) of PSCFD)
|
||||
0.1)))
|
||||
(SETQ DESCENT (FIXR (TIMES SIZE (fetch (PSCFONT DESCENT) of PSCFD)
|
||||
0.1)))
|
||||
(SETQ SCALEFONTP T))
|
||||
(T
|
||||
(* ;; "Here for fonts that only come in specific sizes. Their info is not scaled like built-in Postscript fonts, it is already correct for this pointsize.")
|
||||
|
||||
(COND
|
||||
([SETQ PSCFD (COND
|
||||
((PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
|
||||
((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION
|
||||
DEVICE))
|
||||
(PSCFONT.READFONT FULLNAME]
|
||||
(SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD))
|
||||
(SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD))
|
||||
(SETQ SCALEFONTP NIL]
|
||||
(COND
|
||||
(PSCFD
|
||||
(* ;; "Set up the Charset descriptions and Widths vectors for character set 0:")
|
||||
|
||||
(SETQ FD
|
||||
(create FONTDESCRIPTOR
|
||||
OTHERDEVICEFONTPROPS _ (LIST 'PSCFONT PSCFD)
|
||||
FONTSCALE _ 100
|
||||
FONTDEVICE _ DEVICE
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ SIZE
|
||||
FONTFACE _ FACE
|
||||
ROTATION _ 0
|
||||
\SFHeight _ (IPLUS ASCENT DESCENT)
|
||||
\SFAscent _ ASCENT
|
||||
\SFDescent _ DESCENT
|
||||
FONTTOMCCSFN _ (MCCSMAPFN FONTSPEC)))
|
||||
(FONTPROP FD 'CHARENCODING)
|
||||
(SETQ WIDTHSBLOCK (fetch (CHARSETINFO WIDTHS) of (\INSURECHARSETINFO FD 0)))
|
||||
(SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD))
|
||||
[COND
|
||||
[SCALEFONTP (for CH from 0 to 255
|
||||
do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE
|
||||
(ELT FIXPWIDTHS CH)
|
||||
0.1]
|
||||
(T (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH (ELT FIXPWIDTHS CH]
|
||||
(SETQ PSCWIDTHSBLOCK (\CREATECSINFOELEMENT))
|
||||
|
||||
(* ;; "PSCWIDTHSBLOCK preserves the scaled widths from the original postscript metrics, not the NS mapping of them, which goes into WIDTHSBLOCK.")
|
||||
|
||||
(for CH from 0 to 255 do (\FSETWIDTH PSCWIDTHSBLOCK CH (\FGETWIDTH WIDTHSBLOCK CH
|
||||
)))
|
||||
[LET [(TMP (COND
|
||||
(FULLNAME (FONTSPECFROMFILENAME FULLNAME DEVICE))
|
||||
(UNITFONT (fetch FONTDEVICESPEC of UNITFONT]
|
||||
|
||||
(* ;; "If face got coerced (possibly in recursive call for unit font) then set FONTDEVICESPEC to describe what we really got")
|
||||
|
||||
(COND
|
||||
((AND TMP (NEQ FAMILY (CAR TMP)))
|
||||
(replace FONTDEVICESPEC of FD with (LIST (CAR TMP)
|
||||
SIZE
|
||||
(COPY FACE)
|
||||
0 DEVICE]
|
||||
[LET ((SYMWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'SYMBOL FD ROTATION DEVICE
|
||||
))
|
||||
(DINGWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'ZAPFDINGBATS FD ROTATION
|
||||
DEVICE)))
|
||||
|
||||
(* ;;
|
||||
"Now run thru the mapping table, filling in the new font from whatever source is specified:")
|
||||
|
||||
[MAPHASH *POSTSCRIPT-NS-HASH*
|
||||
(FUNCTION (LAMBDA (MAPPING CODE)
|
||||
(DESTRUCTURING-BIND
|
||||
(KIND CODE2 BASECHAR)
|
||||
MAPPING
|
||||
[MAPHASH *POSTSCRIPT-NS-HASH*
|
||||
(FUNCTION (LAMBDA (MAPPING CODE)
|
||||
(DESTRUCTURING-BIND
|
||||
(KIND CODE2 BASECHAR)
|
||||
MAPPING
|
||||
|
||||
(* ;; "Depending on what kind of item it is, process it:")
|
||||
(* ;;
|
||||
"Depending on what kind of item it is, process it:")
|
||||
|
||||
(SELECTQ KIND
|
||||
(NIL
|
||||
(* ;;
|
||||
(SELECTQ KIND
|
||||
(NIL
|
||||
(* ;;
|
||||
"Translating an NS character to a PSC char in CS 0.")
|
||||
|
||||
(\FSETCHARWIDTH FD CODE (\FGETWIDTH
|
||||
PSCWIDTHSBLOCK
|
||||
(\CHAR8CODE
|
||||
CODE2))))
|
||||
(SYMBOL [AND SYMWIDTHS (\FSETCHARWIDTH
|
||||
FD CODE (ELT SYMWIDTHS
|
||||
(\CHAR8CODE
|
||||
CODE2])
|
||||
(DINGBAT [AND DINGWIDTHS (\FSETCHARWIDTH
|
||||
FD CODE (ELT DINGWIDTHS
|
||||
(\CHAR8CODE
|
||||
CODE2])
|
||||
(FUNCTION
|
||||
(* ;;
|
||||
(\FSETCHARWIDTH FD CODE (\FGETWIDTH
|
||||
PSCWIDTHSBLOCK
|
||||
(\CHAR8CODE CODE2))))
|
||||
(SYMBOL [AND SYMWIDTHS (\FSETCHARWIDTH
|
||||
FD CODE (ELT SYMWIDTHS
|
||||
(\CHAR8CODE
|
||||
CODE2])
|
||||
(DINGBAT [AND DINGWIDTHS (\FSETCHARWIDTH
|
||||
FD CODE
|
||||
(ELT DINGWIDTHS
|
||||
(\CHAR8CODE CODE2])
|
||||
(FUNCTION
|
||||
(* ;;
|
||||
"This is fake and only works for the fractions. Need a better case.")
|
||||
|
||||
[\FSETCHARWIDTH
|
||||
FD CODE
|
||||
(IPLUS (\FGETWIDTH PSCWIDTHSBLOCK 164)
|
||||
(FIXR (FTIMES 1.3
|
||||
(\FGETWIDTH
|
||||
PSCWIDTHSBLOCK
|
||||
(CHARCODE 1])
|
||||
(ACCENT (* ;
|
||||
[\FSETCHARWIDTH
|
||||
FD CODE
|
||||
(IPLUS (\FGETWIDTH PSCWIDTHSBLOCK 164)
|
||||
(FIXR (FTIMES 1.3
|
||||
(\FGETWIDTH
|
||||
PSCWIDTHSBLOCK
|
||||
(CHARCODE 1])
|
||||
(ACCENT (* ;
|
||||
"CODE2 is the rendering character but width comes from width of basechar")
|
||||
(\FSETCHARWIDTH FD CODE (\FGETWIDTH
|
||||
(\FSETCHARWIDTH FD CODE (\FGETWIDTH
|
||||
PSCWIDTHSBLOCK
|
||||
BASECHAR)))
|
||||
(ACCENTPAIR
|
||||
BASECHAR)))
|
||||
(ACCENTPAIR
|
||||
|
||||
(* ;; "CODE2 and BASECHAR are overprinted, width is taken from CODE2 (the real character), basechar is the accent")
|
||||
|
||||
(\FSETCHARWIDTH FD CODE (\FGETWIDTH
|
||||
PSCWIDTHSBLOCK
|
||||
CODE2)))
|
||||
(PROGN
|
||||
(\FSETCHARWIDTH FD CODE (\FGETWIDTH
|
||||
PSCWIDTHSBLOCK
|
||||
CODE2)))
|
||||
(PROGN
|
||||
|
||||
(* ;; "Skip APPLY*'s on this pass, waiting until normal characters get set up, so that widths of other NS characters are available. Also skip anything else")
|
||||
|
||||
NIL]
|
||||
NIL]
|
||||
|
||||
(* ;; "Now do APPLY*'s. MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN). WIDTHFN gets applied to FD and DATA (coerced by INITFN)")
|
||||
(* ;; "Now do APPLY*'s. MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN). WIDTHFN gets applied to FD and DATA (coerced by INITFN)")
|
||||
|
||||
(MAPHASH *POSTSCRIPT-NS-HASH* (FUNCTION (LAMBDA (MAPPING CODE)
|
||||
(CL:WHEN (EQ (CAR MAPPING)
|
||||
'APPLY*)
|
||||
(\FSETCHARWIDTH
|
||||
FD CODE (APPLY* (CADDDR
|
||||
MAPPING
|
||||
)
|
||||
FD
|
||||
(CADR MAPPING))
|
||||
))]
|
||||
FD)
|
||||
(T NIL])
|
||||
(MAPHASH *POSTSCRIPT-NS-HASH* (FUNCTION (LAMBDA (MAPPING CODE)
|
||||
(CL:WHEN (EQ (CAR MAPPING)
|
||||
'APPLY*)
|
||||
(\FSETCHARWIDTH
|
||||
FD CODE (APPLY* (CADDDR
|
||||
MAPPING)
|
||||
FD
|
||||
(CADR MAPPING)
|
||||
)))]
|
||||
FD)
|
||||
(T NIL])
|
||||
|
||||
(\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS
|
||||
[LAMBDA (TYPE FD ROTATION DEVICE) (* ; "Edited 5-Oct-93 18:21 by rmk:")
|
||||
@@ -1111,66 +1124,46 @@
|
||||
NEWWIDTHS)])
|
||||
|
||||
(POSTSCRIPT.FONTSAVAILABLE
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 12-Jan-88 13:04 by Matt Heffron")
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 25-Aug-2025 13:09 by rmk")
|
||||
(* ; "Edited 23-Aug-2025 08:19 by rmk")
|
||||
|
||||
(* ;; "the filtering code was borrowed from Richard Burton's \SEARCHINTERPRESSFONTS. Note that without it [HELVETICA * (MEDIUM REGULAR REGULAR)] would pick up [HELVETICA-NARROW * (MEDIUM REGULAR REGULAR)] as well.")
|
||||
(* ;; "Postscript only has font files of size 1, and only files for %"raw%" postscript families that Medley font families are mapped to by POSTSCRIPTFONTCOERCIONS. Therefore the search doesn't care about the given family, just looks at the corresponding raw files that exist in the directory. ")
|
||||
|
||||
(LET
|
||||
((PATTERN (\FONTFILENAME (OR (CDR (ASSOC FAMILY POSTSCRIPT.FONT.ALIST))
|
||||
FAMILY)
|
||||
SIZE FACE 'PSCFONT))
|
||||
[INVERSE.ALIST (for PAIR in POSTSCRIPT.FONT.ALIST collect (CONS (CDR PAIR)
|
||||
(CAR PAIR]
|
||||
FONTSAVAILABLE)
|
||||
(SETQ FONTSAVAILABLE
|
||||
(for FD in [for DIRECTORY in POSTSCRIPTFONTDIRECTORIES
|
||||
join (for FILE in (DIRECTORY (CONCAT DIRECTORY PATTERN))
|
||||
collect (LET* ((RAWFD (\FONTINFOFROMFILENAME FILE DEVICE)
|
||||
)
|
||||
(RAWNAME (CAR RAWFD)))
|
||||
(RPLACA RAWFD
|
||||
(OR (CDR (ASSOC RAWNAME
|
||||
INVERSE.ALIST))
|
||||
RAWNAME]
|
||||
when (AND (OR (EQ FAMILY '*)
|
||||
(EQ FAMILY (CAR FD)))
|
||||
(OR (EQ SIZE '*)
|
||||
(EQ SIZE (CADR FD))
|
||||
(EQ (CADR FD)
|
||||
1))
|
||||
(OR (EQ FACE '*)
|
||||
(EQUAL FACE (CADDR FD))
|
||||
(EQUAL [CDR (ASSOC FACE '((MRR MEDIUM REGULAR REGULAR)
|
||||
(STANDARD MEDIUM REGULAR REGULAR)
|
||||
(MIR MEDIUM ITALIC REGULAR)
|
||||
(ITALIC MEDIUM ITALIC REGULAR)
|
||||
(BRR BOLD REGULAR REGULAR)
|
||||
(BOLD BOLD REGULAR REGULAR)
|
||||
(BIR BOLD ITALIC REGULAR)
|
||||
(BOLDITALIC BOLD ITALIC REGULAR]
|
||||
(CADDR FD)))
|
||||
(NOT (MEMBER FD $$VAL))) collect FD))
|
||||
(if (EQ SIZE '*)
|
||||
then
|
||||
(LET [(SIZE (fetch (FONTSPEC FSSIZE) of FONTSPEC))
|
||||
(FONTSAVAILABLE (\SEARCHFONTFILES (CAR (COERCEFONTSPEC FONTSPEC]
|
||||
|
||||
(* ;;; "If SIZE was wildcarded, then provide list of pointsizes for Postscript scaled fonts (those with a 1 point descriptor file)")
|
||||
(* ;; "Switch from postscript family names back to the corresponding Medley names.")
|
||||
|
||||
(for FD in FONTSAVAILABLE
|
||||
join (if (EQ 1 (CADR FD))
|
||||
then (CONS FD (for NF
|
||||
in (for S from 2 to
|
||||
\POSTSCRIPT.MAX.WILD.FONTSIZE
|
||||
collect (LET ((NFD (COPY FD)))
|
||||
(RPLACA (CDR NFD)
|
||||
S)
|
||||
NFD))
|
||||
unless (MEMBER NF FONTSAVAILABLE) collect
|
||||
NF))
|
||||
else (LIST FD)))
|
||||
else FONTSAVAILABLE])
|
||||
(for FS in FONTSAVAILABLE
|
||||
do (change (fetch (FONTSPEC FSFAMILY) of FS)
|
||||
(OR [CAR (find C in (FONTDEVICEPROP FONTSPEC 'FONTCOERCIONS)
|
||||
suchthat
|
||||
|
||||
(* ;; "C is (medley (ps 1))--match ps return medley")
|
||||
|
||||
(EQ DATUM (CAR (CADR C]
|
||||
DATUM)))
|
||||
(if (EQ SIZE '*)
|
||||
then
|
||||
(* ;; "If SIZE was wildcarded, then provide list of pointsizes for the Postscript scaled fonts (those with a 1 point descriptor file)")
|
||||
|
||||
(* ;;
|
||||
"RMK: Maybe just provide the sizes that exist for all the corresponding display fonts?")
|
||||
|
||||
(for FS in FONTSAVAILABLE
|
||||
do (for S NFS from 2 to \POSTSCRIPT.MAX.WILD.FONTSIZE
|
||||
eachtime (SETQ NFS (create FONTSPEC using FS FSSIZE _ S))
|
||||
unless (MEMBER NFS FONTSAVAILABLE) do (push FONTSAVAILABLE NFS)))
|
||||
else
|
||||
(* ;; "Otherwise, replace the 1 with the requested SIZE.")
|
||||
|
||||
(for FS in FONTSAVAILABLE do (replace (FONTSPEC FSSIZE) of FS with SIZE)))
|
||||
FONTSAVAILABLE])
|
||||
|
||||
(POSTSCRIPT.FONTEXISTS?
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 16-Jun-2025 00:04 by rmk")
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 3-Sep-2025 23:12 by rmk")
|
||||
(* ; "Edited 18-Aug-2025 09:44 by rmk")
|
||||
(* ; "Edited 16-Jun-2025 00:04 by rmk")
|
||||
(* ; "Edited 29-Oct-93 16:39 by rmk:")
|
||||
(* ; "Edited 3-Feb-93 17:22 by jds")
|
||||
|
||||
@@ -1178,27 +1171,15 @@
|
||||
|
||||
(* ;; "Since a 1 point font is ridiculously small, and it is the standard size for Postscript font info, size 1 is presumed to be the base for all postscript fonts.")
|
||||
|
||||
(LET ((WEIGHT (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(SLOPE (fetch (FONTFACE SLOPE) of FACE))
|
||||
(EXPANSION (fetch (FONTFACE EXPANSION) of FACE)))
|
||||
(LET (FAMILY SIZE FACE ROTATION DEVICE WEIGHT SLOPE EXPANSION)
|
||||
(SPREADFONTSPEC FONTSPEC)
|
||||
(SETQ WEIGHT (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(SETQ SLOPE (fetch (FONTFACE SLOPE) of FACE))
|
||||
(SETQ EXPANSION (fetch (FONTFACE EXPANSION) of FACE))
|
||||
(OR (PSCFONT.SPELLFILE FAMILY 1 FACE ROTATION DEVICE)
|
||||
(PSCFONTFROMCACHE.COERCEFILE FAMILY 1 WEIGHT SLOPE EXPANSION ROTATION DEVICE)
|
||||
(PSCFONT.COERCEFILE FAMILY 1 WEIGHT SLOPE EXPANSION ROTATION DEVICE])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Until macro in FONT is exported")
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH)
|
||||
(\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO
|
||||
(\CHARSET CHARCODE)
|
||||
FONTDESC))
|
||||
(\CHAR8CODE CHARCODE)
|
||||
WIDTH)))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(OPENPOSTSCRIPTSTREAM
|
||||
@@ -1419,11 +1400,12 @@
|
||||
`(REGION ,POSTSCRIPT.DEFAULT.PAGEREGION ROTATION ,(NOT (NOT POSTSCRIPT.TEXTFILE.LANDSCAPE])
|
||||
|
||||
(POSTSCRIPTFILEP
|
||||
[LAMBDA (FILE) (* ; "Edited 21-Nov-2023 17:04 by rmk")
|
||||
[LAMBDA (FILE) (* ; "Edited 10-Sep-2025 14:51 by rmk")
|
||||
(* ; "Edited 21-Nov-2023 17:04 by rmk")
|
||||
(* ; "Edited 5-Mar-93 21:40 by rmk:")
|
||||
(* ; "Edited 14-Jan-93 10:56 by jds")
|
||||
(OR (CL:MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION)
|
||||
[CADR (ASSOC 'EXTENSION (CDR (ASSOC 'POSTSCRIPT PRINTFILETYPES]
|
||||
(OR (CL:MEMBER (FILENAMEFIELD FILE 'EXTENSION)
|
||||
(EXTENSIONS.FOR.PRINTFILETYPE 'POSTSCRIPT)
|
||||
:TEST
|
||||
(FUNCTION STRING-EQUAL))
|
||||
(RESETLST
|
||||
@@ -2304,29 +2286,23 @@
|
||||
CHARCODE])
|
||||
|
||||
(\CREATECHARSET.PSC
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
|
||||
(* ; "Edited 8-May-93 22:55 by rmk:")
|
||||
(LET* ((CSINFO (CREATE CHARSETINFO
|
||||
[LAMBDA (FONTSPEC FONT CHARSET) (* ; "Edited 3-Sep-2025 23:11 by rmk")
|
||||
(* ; "Edited 8-May-93 22:55 by rmk:")
|
||||
(LET* ((CSINFO (create CHARSETINFO
|
||||
OFFSETS _ NIL))
|
||||
(WIDTHS (FETCH (CHARSETINFO WIDTHS) OF CSINFO)))
|
||||
(REPLACE (CHARSETINFO IMAGEWIDTHS) OF CSINFO WITH WIDTHS)
|
||||
(WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)))
|
||||
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with WIDTHS)
|
||||
|
||||
(* ;; "Make imagewidths point to widths. Shouldn't matter to anyone, since imagewidths really has to do with bitmaps etc. But...")
|
||||
(* ;; "Make imagewidths point to widths. Shouldn't matter to anyone, since imagewidths really has to do with bitmaps etc. But...")
|
||||
|
||||
(CL:UNLESS (EQ CHARSET 0)
|
||||
|
||||
(* ;; "For all charsets other than 0, initialize widths with width of black box=average char width. We know that the AVGCHARWIDTH field of the FONTDESC will eventually be the width of A, but that might not be filled in when this is executed inside POSTSCRIPT.FONTCREATE--it's only after the return to FONTCREATE itself that this gets filled in. However, we do know that charset 0 is all set up before any other characters are dealt with.")
|
||||
(* ;; "For all charsets other than 0, initialize widths with width of black box=average char width. We know that the AVGCHARWIDTH field of the FONT will eventually be the width of A, but that might not be filled in when this is executed inside POSTSCRIPT.FONTCREATE--it's only after the return to FONTCREATE itself that this gets filled in. However, we do know that charset 0 is all set up before any other characters are dealt with.")
|
||||
|
||||
(FOR I (AVGCHARWIDTH _ (CHARWIDTH (CHARCODE A)
|
||||
FONTDESC)) FROM 0 TO 255
|
||||
FIRST (CL:WHEN (EQ 0 AVGCHARWIDTH)
|
||||
(* ;; "RMK: Should it use the FONTSLUGWIDTH")
|
||||
|
||||
(* ;;
|
||||
"This is what \AVGCHARWIDTH in FONT does, but we don't have it here. Just to be extremely safe.")
|
||||
|
||||
[SETQ AVGCHARWIDTH (MAX 1 (FIXR (FTIMES 0.6 (FONTPROP FONTDESC
|
||||
'HEIGHT])
|
||||
DO (\FSETWIDTH WIDTHS I AVGCHARWIDTH)))
|
||||
(for I (AVGCHARWIDTH _ (\AVGCHARWIDTH FONT)) from 0 to \MAXTHINCHAR
|
||||
do (\FSETWIDTH WIDTHS I AVGCHARWIDTH)))
|
||||
CSINFO])
|
||||
|
||||
(\DRAWARC.PSC
|
||||
@@ -3125,22 +3101,21 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\POSTSCRIPT.CHANGECHARSET
|
||||
[LAMBDA (PSDATA CHARSET) (* ; "Edited 29-Apr-93 13:51 by rmk:")
|
||||
[LAMBDA (PSDATA CHARSET) (* ; "Edited 30-Aug-2025 23:24 by rmk")
|
||||
(* ; "Edited 29-Apr-93 13:51 by rmk:")
|
||||
|
||||
(* ;;
|
||||
"Called when the character set information cached in a display stream doesn't correspond to CHARSET")
|
||||
|
||||
(PROG* ((FONT (ffetch POSTSCRIPTFONT of PSDATA))
|
||||
(CSINFO (\GETCHARSETINFO CHARSET FONT)))
|
||||
|
||||
(* ;; "since the call to \getcharsetinfo has NOSLUG? = NIL, we know that we will get a reasonable character set back")
|
||||
|
||||
(CSINFO (\INSURECHARSETINFO FONT CHARSET)))
|
||||
(UNINTERRUPTABLY
|
||||
(freplace POSTSCRIPTWIDTHS of PSDATA with (ffetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
(freplace POSTSCRIPTNSCHARSET of PSDATA with CHARSET))])
|
||||
|
||||
(\POSTSCRIPT.OUTCHARFN
|
||||
[LAMBDA (STREAM CHAR) (* ; "Edited 23-May-93 12:00 by rmk:")
|
||||
[LAMBDA (STREAM CHAR) (* ; "Edited 8-Sep-2025 09:50 by rmk")
|
||||
(* ; "Edited 23-May-93 12:00 by rmk:")
|
||||
(* ; "Edited 4-May-93 02:20 by jds")
|
||||
(* ; "Edited 3-Feb-93 00:45 by jds")
|
||||
|
||||
@@ -3152,6 +3127,7 @@
|
||||
|
||||
(DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE)
|
||||
(LOCALVARS . T))
|
||||
(SETQ CHAR (MTOX$CODE CHAR))
|
||||
(LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))
|
||||
(XPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA))
|
||||
(FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA))
|
||||
@@ -4305,6 +4281,10 @@
|
||||
(\PS.SCALE0 100)
|
||||
(\PS.TEMPARRAYLEN 20))
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS POSTSCRIPTFONTEXTENSIONS POSTSCRIPTFONTDIRECTORIES)
|
||||
)
|
||||
|
||||
(RPAQ? POSTSCRIPT.BITMAP.SCALE 1)
|
||||
|
||||
@@ -4325,6 +4305,24 @@
|
||||
"{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/")
|
||||
(T "{DSK}<LISPFILES>POSTSCRIPT>"))))
|
||||
|
||||
(RPAQ? POSTSCRIPTFONTEXTENSIONS '(PSCFONT PF PSC))
|
||||
|
||||
(RPAQ? POSTSCRIPTFONTCOERCIONS
|
||||
'((HELVETICA (HELVETICA 1))
|
||||
(HELVETICAD (HELVETICA 1))
|
||||
(TIMESROMAN (TIMES 1))
|
||||
(TIMESROMAND (TIMES 1))
|
||||
(COURIER (COURIER 1))
|
||||
(GACHA (COURIER 1))
|
||||
(CLASSIC (NEWCENTURYSCHLBK 1))
|
||||
(MODERN (HELVETICA 1))
|
||||
(CREAM (HELVETICA 1))
|
||||
(TERMINAL (COURIER 1))
|
||||
(LOGO (HELVETICA 1))
|
||||
(OPTIMA (PALATINO 1))
|
||||
(TITAN (COURIER 1))
|
||||
(* (* 1))))
|
||||
|
||||
(RPAQ? \POSTSCRIPT.MAX.WILD.FONTSIZE 72)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -4414,39 +4412,39 @@
|
||||
(ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (22458 32954 (POSTSCRIPT.INIT 22468 . 29560) (POSTSCRIPT.PUTRGBCOLOR 29562 . 30584) (
|
||||
\PSC.COLOR.TO.RGB 30586 . 32952)) (33940 69653 (PSCFONT.READFONT 33950 . 35858) (PSCFONT.SPELLFILE
|
||||
35860 . 36557) (PSCFONT.COERCEFILE 36559 . 38131) (PSCFONTFROMCACHE.SPELLFILE 38133 . 39118) (
|
||||
PSCFONTFROMCACHE.COERCEFILE 39120 . 40772) (PSCFONT.WRITEFONT 40774 . 41789) (READ-AFM-FILE 41791 .
|
||||
47662) (CONVERT-AFM-FILES 47664 . 48876) (POSTSCRIPT.GETFONTID 48878 . 50273) (POSTSCRIPT.FONTCREATE
|
||||
50275 . 62428) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 62430 . 64827) (POSTSCRIPT.FONTSAVAILABLE 64829
|
||||
. 68595) (POSTSCRIPT.FONTEXISTS? 68597 . 69651)) (70208 79493 (OPENPOSTSCRIPTSTREAM 70218 . 79159) (
|
||||
CLOSEPOSTSCRIPTSTREAM 79161 . 79491)) (79538 85592 (POSTSCRIPT.HARDCOPYW 79548 . 82655) (
|
||||
POSTSCRIPT.TEDIT 82657 . 83141) (POSTSCRIPT.TEXT 83143 . 83434) (POSTSCRIPTFILEP 83436 . 84543) (
|
||||
MAKEEPSFILE 84545 . 85590)) (85593 129167 (POSTSCRIPT.BITMAPSCALE 85603 . 88059) (
|
||||
POSTSCRIPT.CLOSESTRING 88061 . 88614) (POSTSCRIPT.ENDPAGE 88616 . 89507) (POSTSCRIPT.OUTSTR 89509 .
|
||||
90726) (POSTSCRIPT.PUTBITMAPBYTES 90728 . 99199) (POSTSCRIPT.PUTCOMMAND 99201 . 100190) (
|
||||
POSTSCRIPT.SET-FAKE-LANDSCAPE 100192 . 104712) (POSTSCRIPT.SHOWACCUM 104714 . 106869) (
|
||||
POSTSCRIPT.STARTPAGE 106871 . 109403) (\POSTSCRIPTTAB 109405 . 110202) (\PS.BOUTFIXP 110204 . 111484)
|
||||
(\PS.SCALEHACK 111486 . 114129) (\PS.SCALEREGION 114131 . 114691) (\SCALEDBITBLT.PSC 114693 . 119003)
|
||||
(\SETPOS.PSC 119005 . 119486) (\SETXFORM.PSC 119488 . 122072) (\STRINGWIDTH.PSC 122074 . 122547) (
|
||||
\SWITCHFONTS.PSC 122549 . 128041) (\TERPRI.PSC 128043 . 129165)) (129202 183400 (\BITBLT.PSC 129212 .
|
||||
129764) (\BLTSHADE.PSC 129766 . 134427) (\CHARWIDTH.PSC 134429 . 134936) (\CREATECHARSET.PSC 134938 .
|
||||
136636) (\DRAWARC.PSC 136638 . 139016) (\DRAWCIRCLE.PSC 139018 . 141269) (\DRAWCURVE.PSC 141271 .
|
||||
145115) (\DRAWELLIPSE.PSC 145117 . 147481) (\DRAWLINE.PSC 147483 . 150223) (\DRAWPOINT.PSC 150225 .
|
||||
150801) (\DRAWPOLYGON.PSC 150803 . 153932) (\DSPBOTTOMMARGIN.PSC 153934 . 154621) (
|
||||
\DSPCLIPPINGREGION.PSC 154623 . 155998) (\DSPCOLOR.PSC 156000 . 156931) (\DSPFONT.PSC 156933 . 160570)
|
||||
(\DSPLEFTMARGIN.PSC 160572 . 161258) (\DSPLINEFEED.PSC 161260 . 161850) (\DSPPUSHSTATE.PSC 161852 .
|
||||
163312) (\DSPPOPSTATE.PSC 163314 . 166799) (\DSPRESET.PSC 166801 . 167466) (\DSPRIGHTMARGIN.PSC 167468
|
||||
. 168157) (\DSPROTATE.PSC 168159 . 169158) (\DSPSCALE.PSC 169160 . 170112) (\DSPSCALE2.PSC 170114 .
|
||||
170954) (\DSPSPACEFACTOR.PSC 170956 . 171877) (\DSPTOPMARGIN.PSC 171879 . 172450) (\DSPTRANSLATE.PSC
|
||||
172452 . 174483) (\DSPXPOSITION.PSC 174485 . 175049) (\DSPYPOSITION.PSC 175051 . 175642) (
|
||||
\FILLCIRCLE.PSC 175644 . 177869) (\FILLPOLYGON.PSC 177871 . 181108) (\FIXLINELENGTH.PSC 181110 .
|
||||
182429) (\MOVETO.PSC 182431 . 183201) (\NEWPAGE.PSC 183203 . 183398)) (183456 205479 (
|
||||
\POSTSCRIPT.CHANGECHARSET 183466 . 184203) (\POSTSCRIPT.OUTCHARFN 184205 . 196333) (
|
||||
\POSTSCRIPT.PRINTSLUG 196335 . 198059) (\POSTSCRIPT.SPECIALOUTCHARFN 198061 . 200412) (\UPDATE.PSC
|
||||
200414 . 201660) (\POSTSCRIPT.ACCENTFN 201662 . 202604) (\POSTSCRIPT.ACCENTPAIR 202606 . 205477)) (
|
||||
205577 207222 (\PSC.SPACEDISP 205587 . 205866) (\PSC.SPACEWID 205868 . 206487) (\PSC.SYMBOLS 206489 .
|
||||
207220)) (207331 210322 (\POSTSCRIPT.NSHASH 207341 . 210320)) (255096 255802 (POSTSCRIPTSEND 255106 .
|
||||
255800)))))
|
||||
(FILEMAP (NIL (23396 33604 (POSTSCRIPT.INIT 23406 . 30210) (POSTSCRIPT.PUTRGBCOLOR 30212 . 31234) (
|
||||
\PSC.COLOR.TO.RGB 31236 . 33602)) (34590 69697 (PSCFONT.READFONT 34600 . 36508) (PSCFONT.SPELLFILE
|
||||
36510 . 37323) (PSCFONT.COERCEFILE 37325 . 38897) (PSCFONTFROMCACHE.SPELLFILE 38899 . 39884) (
|
||||
PSCFONTFROMCACHE.COERCEFILE 39886 . 41538) (PSCFONT.WRITEFONT 41540 . 42555) (READ-AFM-FILE 42557 .
|
||||
48428) (CONVERT-AFM-FILES 48430 . 49642) (POSTSCRIPT.GETFONTID 49644 . 51039) (POSTSCRIPT.FONTCREATE
|
||||
51041 . 63724) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 63726 . 66123) (POSTSCRIPT.FONTSAVAILABLE 66125
|
||||
. 68308) (POSTSCRIPT.FONTEXISTS? 68310 . 69695)) (69698 78983 (OPENPOSTSCRIPTSTREAM 69708 . 78649) (
|
||||
CLOSEPOSTSCRIPTSTREAM 78651 . 78981)) (79028 85162 (POSTSCRIPT.HARDCOPYW 79038 . 82145) (
|
||||
POSTSCRIPT.TEDIT 82147 . 82631) (POSTSCRIPT.TEXT 82633 . 82924) (POSTSCRIPTFILEP 82926 . 84113) (
|
||||
MAKEEPSFILE 84115 . 85160)) (85163 128737 (POSTSCRIPT.BITMAPSCALE 85173 . 87629) (
|
||||
POSTSCRIPT.CLOSESTRING 87631 . 88184) (POSTSCRIPT.ENDPAGE 88186 . 89077) (POSTSCRIPT.OUTSTR 89079 .
|
||||
90296) (POSTSCRIPT.PUTBITMAPBYTES 90298 . 98769) (POSTSCRIPT.PUTCOMMAND 98771 . 99760) (
|
||||
POSTSCRIPT.SET-FAKE-LANDSCAPE 99762 . 104282) (POSTSCRIPT.SHOWACCUM 104284 . 106439) (
|
||||
POSTSCRIPT.STARTPAGE 106441 . 108973) (\POSTSCRIPTTAB 108975 . 109772) (\PS.BOUTFIXP 109774 . 111054)
|
||||
(\PS.SCALEHACK 111056 . 113699) (\PS.SCALEREGION 113701 . 114261) (\SCALEDBITBLT.PSC 114263 . 118573)
|
||||
(\SETPOS.PSC 118575 . 119056) (\SETXFORM.PSC 119058 . 121642) (\STRINGWIDTH.PSC 121644 . 122117) (
|
||||
\SWITCHFONTS.PSC 122119 . 127611) (\TERPRI.PSC 127613 . 128735)) (128772 182628 (\BITBLT.PSC 128782 .
|
||||
129334) (\BLTSHADE.PSC 129336 . 133997) (\CHARWIDTH.PSC 133999 . 134506) (\CREATECHARSET.PSC 134508 .
|
||||
135864) (\DRAWARC.PSC 135866 . 138244) (\DRAWCIRCLE.PSC 138246 . 140497) (\DRAWCURVE.PSC 140499 .
|
||||
144343) (\DRAWELLIPSE.PSC 144345 . 146709) (\DRAWLINE.PSC 146711 . 149451) (\DRAWPOINT.PSC 149453 .
|
||||
150029) (\DRAWPOLYGON.PSC 150031 . 153160) (\DSPBOTTOMMARGIN.PSC 153162 . 153849) (
|
||||
\DSPCLIPPINGREGION.PSC 153851 . 155226) (\DSPCOLOR.PSC 155228 . 156159) (\DSPFONT.PSC 156161 . 159798)
|
||||
(\DSPLEFTMARGIN.PSC 159800 . 160486) (\DSPLINEFEED.PSC 160488 . 161078) (\DSPPUSHSTATE.PSC 161080 .
|
||||
162540) (\DSPPOPSTATE.PSC 162542 . 166027) (\DSPRESET.PSC 166029 . 166694) (\DSPRIGHTMARGIN.PSC 166696
|
||||
. 167385) (\DSPROTATE.PSC 167387 . 168386) (\DSPSCALE.PSC 168388 . 169340) (\DSPSCALE2.PSC 169342 .
|
||||
170182) (\DSPSPACEFACTOR.PSC 170184 . 171105) (\DSPTOPMARGIN.PSC 171107 . 171678) (\DSPTRANSLATE.PSC
|
||||
171680 . 173711) (\DSPXPOSITION.PSC 173713 . 174277) (\DSPYPOSITION.PSC 174279 . 174870) (
|
||||
\FILLCIRCLE.PSC 174872 . 177097) (\FILLPOLYGON.PSC 177099 . 180336) (\FIXLINELENGTH.PSC 180338 .
|
||||
181657) (\MOVETO.PSC 181659 . 182429) (\NEWPAGE.PSC 182431 . 182626)) (182684 204830 (
|
||||
\POSTSCRIPT.CHANGECHARSET 182694 . 183412) (\POSTSCRIPT.OUTCHARFN 183414 . 195684) (
|
||||
\POSTSCRIPT.PRINTSLUG 195686 . 197410) (\POSTSCRIPT.SPECIALOUTCHARFN 197412 . 199763) (\UPDATE.PSC
|
||||
199765 . 201011) (\POSTSCRIPT.ACCENTFN 201013 . 201955) (\POSTSCRIPT.ACCENTPAIR 201957 . 204828)) (
|
||||
204928 206573 (\PSC.SPACEDISP 204938 . 205217) (\PSC.SPACEWID 205219 . 205838) (\PSC.SYMBOLS 205840 .
|
||||
206571)) (206682 209673 (\POSTSCRIPT.NSHASH 206692 . 209671)) (255083 255789 (POSTSCRIPTSEND 255093 .
|
||||
255787)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,17 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 5-Jun-2022 00:14:07"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>COREIO.;17 57355
|
||||
(FILECREATED "11-Sep-2025 16:49:07" {WMEDLEY}<sources>COREIO.;18 56903
|
||||
|
||||
:CHANGES-TO (FNS \CORE.OPENFILE)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE " 4-Jun-2022 16:30:20"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>COREIO.;16)
|
||||
:CHANGES-TO (FNS \CORE.DIRECTORYNAMEP)
|
||||
|
||||
:PREVIOUS-DATE " 5-Jun-2022 00:14:07" {WMEDLEY}<sources>COREIO.;17)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COREIOCOMS)
|
||||
|
||||
@@ -91,8 +87,13 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(RETURN (fetch IOFILEFULLNAME of INFOBLOCK])
|
||||
|
||||
(\CORE.DIRECTORYNAMEP
|
||||
[LAMBDA (DIRNAME DEV) (* ; "Edited 18-Jan-2022 11:17 by rmk")
|
||||
(* ; "Edited 10-Jan-2022 22:33 by rmk")
|
||||
[LAMBDA (DIRNAME DEV)
|
||||
|
||||
(* ;; "Edited 11-Sep-2025 16:48 by rmk")
|
||||
|
||||
(* ;; "Edited 18-Jan-2022 11:17 by rmk")
|
||||
|
||||
(* ;; "Edited 10-Jan-2022 22:33 by rmk")
|
||||
|
||||
(* ;;
|
||||
"Edited 9-Jan-2022 12:42 by rmk: Using the new FILEDIRCASEARRAY so that slashes and brackets match")
|
||||
@@ -103,22 +104,20 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
|
||||
(CL:WHEN DIRNAME
|
||||
|
||||
(* ;; "The DIRNAME could be just {CORE}, which always is OK, or {CORE}xxx. If the latter, then we want it to be a directory and not a file (assuming that xxx and xxx> can't both exist.")
|
||||
(* ;; "Returns NIL for a DIRNAME of just {CORE}, or {CORE}xxx. If the latter, then we want it to be a directory and not a file (assuming that xxx and xxx> can't both exist.")
|
||||
|
||||
(IF (EQ (CHARCODE })
|
||||
(NTHCHARCODE DIRNAME -1))
|
||||
ELSE (CL:UNLESS (MEMB (NTHCHARCODE DIRNAME -1)
|
||||
(CHARCODE (> /)))
|
||||
(SETQ DIRNAME (CONCAT DIRNAME ">")))
|
||||
[LET [(DIR (FILENAMEFIELD DIRNAME 'DIRECTORY]
|
||||
(CL:WHEN DIR
|
||||
(SETQ DIR (CONCAT DIR ">"))
|
||||
|
||||
(* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)")
|
||||
(* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)")
|
||||
|
||||
(FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY))
|
||||
FIRST (CL:UNLESS (EQ DIRPOS 1)
|
||||
(SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS)))
|
||||
IN (CDR (FETCH COREDIRECTORY OF DEV)) WHEN (STRPOS DIRNAME (CAR ENTRY)
|
||||
1 NIL T NIL FILEDIRCASEARRAY)
|
||||
DO (RETURN T))))])
|
||||
(FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY))
|
||||
FIRST (CL:UNLESS (EQ DIRPOS 1)
|
||||
(SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS)))
|
||||
IN (CDR (FETCH COREDIRECTORY OF DEV))
|
||||
WHEN (STRPOS DIRNAME (CAR ENTRY)
|
||||
1 NIL T NIL FILEDIRCASEARRAY) DO (RETURN T)))])])
|
||||
|
||||
(\CORE.FINDPAGE
|
||||
[LAMBDA (STREAM PN) (* bvm%: "20-Apr-85 13:32")
|
||||
@@ -997,19 +996,17 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(LOCALVARS . T)
|
||||
)
|
||||
)
|
||||
(PUTPROPS COREIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
1993 1999 2018))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1717 46448 (\CORE.CLOSEFILE 1727 . 2500) (\CORE.DELETEFILE 2502 . 4488) (
|
||||
\CORE.DIRECTORYNAMEP 4490 . 6171) (\CORE.FINDPAGE 6173 . 9402) (\CORE.GENERATEFILES 9404 . 11991) (
|
||||
\CORE.NEXTFILEFN 11993 . 12492) (\CORE.FILEINFOFN 12494 . 12723) (\CORE.GETFILEHANDLE 12725 . 14879) (
|
||||
\CORE.GETFILEINFO 14881 . 15844) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15846 . 17383) (\CORE.GETFILENAME
|
||||
17385 . 19674) (\CORE.GETINFOBLOCK 19676 . 22299) (\CORE.NAMESCAN 22301 . 23848) (\CORE.NAMESEGMENT
|
||||
23850 . 24287) (\CORE.OPENFILE 24289 . 27681) (\COREFILE.SETPARAMETERS 27683 . 29864) (
|
||||
\CORE.PACKFILENAME 29866 . 30261) (\CORE.RELEASEPAGES 30263 . 30864) (\CORE.SETFILEPTR 30866 . 31965)
|
||||
(\CORE.UPDATEOF 31967 . 33596) (\CORE.BACKFILEPTR 33598 . 35806) (\CORE.SETEOFPTR 35808 . 37677) (
|
||||
\CORE.SETACCESSTIME 37679 . 38304) (\CORE.SETFILEINFO 38306 . 40608) (\CORE.GETNEXTBUFFER 40610 .
|
||||
44566) (\CORE.UNPACKFILENAME 44568 . 46446)) (46449 50082 (COREDEVICE 46459 . 46630) (
|
||||
\CREATECOREDEVICE 46632 . 50080)) (50083 52497 (\NODIRCOREFDEV 50093 . 50690) (\NODIRCORE.OPENFILE
|
||||
50692 . 52495)))))
|
||||
(FILEMAP (NIL (1572 46115 (\CORE.CLOSEFILE 1582 . 2355) (\CORE.DELETEFILE 2357 . 4343) (
|
||||
\CORE.DIRECTORYNAMEP 4345 . 5838) (\CORE.FINDPAGE 5840 . 9069) (\CORE.GENERATEFILES 9071 . 11658) (
|
||||
\CORE.NEXTFILEFN 11660 . 12159) (\CORE.FILEINFOFN 12161 . 12390) (\CORE.GETFILEHANDLE 12392 . 14546) (
|
||||
\CORE.GETFILEINFO 14548 . 15511) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15513 . 17050) (\CORE.GETFILENAME
|
||||
17052 . 19341) (\CORE.GETINFOBLOCK 19343 . 21966) (\CORE.NAMESCAN 21968 . 23515) (\CORE.NAMESEGMENT
|
||||
23517 . 23954) (\CORE.OPENFILE 23956 . 27348) (\COREFILE.SETPARAMETERS 27350 . 29531) (
|
||||
\CORE.PACKFILENAME 29533 . 29928) (\CORE.RELEASEPAGES 29930 . 30531) (\CORE.SETFILEPTR 30533 . 31632)
|
||||
(\CORE.UPDATEOF 31634 . 33263) (\CORE.BACKFILEPTR 33265 . 35473) (\CORE.SETEOFPTR 35475 . 37344) (
|
||||
\CORE.SETACCESSTIME 37346 . 37971) (\CORE.SETFILEINFO 37973 . 40275) (\CORE.GETNEXTBUFFER 40277 .
|
||||
44233) (\CORE.UNPACKFILENAME 44235 . 46113)) (46116 49749 (COREDEVICE 46126 . 46297) (
|
||||
\CREATECOREDEVICE 46299 . 49747)) (49750 52164 (\NODIRCOREFDEV 49760 . 50357) (\NODIRCORE.OPENFILE
|
||||
50359 . 52162)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
120
sources/FILEIO
120
sources/FILEIO
@@ -1,12 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "25-Dec-2024 10:56:37" {WMEDLEY}<sources>FILEIO.;138 166550
|
||||
(FILECREATED "11-Sep-2025 20:49:24"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>FILEIO.;140 166949
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS SETFILEINFO \DO.PARAMS.AT.OPEN \RENAMEFILE)
|
||||
:CHANGES-TO (FNS COPYCHARS)
|
||||
|
||||
:PREVIOUS-DATE "18-Dec-2024 21:08:09" {WMEDLEY}<sources>FILEIO.;135)
|
||||
:PREVIOUS-DATE "24-Apr-2025 22:16:47"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>FILEIO.;139)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT FILEIOCOMS)
|
||||
@@ -2223,31 +2225,32 @@ update the map")
|
||||
])
|
||||
|
||||
(COPYCHARS
|
||||
[LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 13-Aug-2021 18:39 by rmk:")
|
||||
(* ; "Edited 14-Jun-2021 22:08 by rmk:")
|
||||
(* ; "Edited 8-Dec-95 16:38 by rmk:")
|
||||
(* ; "Edited 26-Mar-99 12:13 by rmk:")
|
||||
[LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 11-Sep-2025 20:47 by rmk")
|
||||
(* ; "Edited 13-Aug-2021 18:39 by rmk:")
|
||||
(* ; "Edited 14-Jun-2021 22:08 by rmk:")
|
||||
(* ; "Edited 8-Dec-95 16:38 by rmk:")
|
||||
(* ; "Edited 26-Mar-99 12:13 by rmk:")
|
||||
|
||||
(* ;; "This is similar to COPYBYTES except that conversion is done between the EOL convention and externalformat of the input and the EOL convention/external format of the output")
|
||||
(* ;; "This is similar to COPYBYTES except that conversion is done between the EOL convention and externalformat of the input and the EOL convention/external format of the output. This assumes that an ANY.EOLC source file is actually the same as the destination.")
|
||||
|
||||
[PROG ((SRCSTRM (\GETSTREAM SRCFIL))
|
||||
(DSTSTRM (\GETSTREAM DSTFIL))
|
||||
(ACTUALSTART 0)
|
||||
RAP ACTUALEND EOF SRCEOLC DSTEOLC CH)
|
||||
(CL:WHEN (AND (EQ (SETQ SRCEOLC (fetch EOLCONVENTION of SRCSTRM))
|
||||
(SETQ DSTEOLC (fetch EOLCONVENTION of DSTSTRM)))
|
||||
(CL:WHEN (AND (OR (EQ (SETQ SRCEOLC (fetch EOLCONVENTION of SRCSTRM))
|
||||
(SETQ DSTEOLC (fetch EOLCONVENTION of DSTSTRM)))
|
||||
(EQ ANY.EOLC (fetch EOLCONVENTION of SRCSTRM)))
|
||||
(EQ (FETCH EXTERNALFORMAT OF SRCSTRM)
|
||||
(FETCH EXTERNALFORMAT OF DSTSTRM)))
|
||||
(RETURN (COPYBYTES SRCSTRM DSTSTRM START END)))
|
||||
|
||||
(* ;; "Format or EOL convention are different. So first decode the START END specification")
|
||||
(* ;; "Format or EOL convention are different. So first decode the START END specification")
|
||||
|
||||
[COND
|
||||
((SETQ RAP (fetch RANDOMACCESSP of (fetch DEVICE of SRCSTRM)))
|
||||
(SETQ EOF (\GETEOFPTR SRCSTRM]
|
||||
(COND
|
||||
[END (OR RAP (ERROR "COPYCHARS: Source file is not random access" (fetch
|
||||
FULLFILENAME
|
||||
[END (OR RAP (ERROR "COPYCHARS: Source file is not random access" (fetch FULLFILENAME
|
||||
of SRCSTRM)))
|
||||
(OR (type? BYTEPTR (SETQ ACTUALSTART (FIX START)))
|
||||
(LISPERROR "ILLEGAL ARG" START))
|
||||
@@ -2265,21 +2268,20 @@ update the map")
|
||||
(RAP (SETQ ACTUALSTART (\GETFILEPTR SRCSTRM))
|
||||
(SETQ ACTUALEND EOF))
|
||||
(T
|
||||
(* ;;
|
||||
"Not random access and START and END are both NIL, just copy to the end of file,no need to count.")
|
||||
(* ;;
|
||||
"Not random access and START and END are both NIL, just copy to the end of file,no need to count.")
|
||||
|
||||
(until (\EOFP SRCSTRM) do (\OUTCHAR DSTSTRM (\INCCODE.EOLC SRCSTRM SRCEOLC)))
|
||||
(RETURN)))
|
||||
(CL:UNLESS (IGEQ ACTUALEND ACTUALSTART)
|
||||
(ERROR "Negative number of bytes to copy" (IDIFFERENCE ACTUALEND ACTUALSTART)))
|
||||
|
||||
(* ;; "We now know which bytes we need to copy, in the case that there is an EOL/format mismatch. If we assume that this is fairly unusual and that we don't want to assume here that we know how the CR and LF are byte-coded, we don't try to optimize for an EOL-only change. We just go generic.")
|
||||
(* ;; "We now know which bytes we need to copy, in the case that there is an EOL/format mismatch. If we assume that this is fairly unusual and that we don't want to assume here that we know how the CR and LF are byte-coded, we don't try to optimize for an EOL-only change. We just go generic.")
|
||||
|
||||
(* ;; "The \INCCODE.EOLC and \OUTCHAR handle all format and EOL issues.")
|
||||
(* ;; "The \INCCODE.EOLC and \OUTCHAR handle all format and EOL issues.")
|
||||
|
||||
(BIND (CNT _ (IDIFFERENCE ACTUALEND ACTUALSTART)) DECLARE (SPECVARS CNT)
|
||||
WHILE (IGREATERP CNT 0) DO (\OUTCHAR DSTSTRM (\INCCODE.EOLC SRCSTRM NIL
|
||||
'CNT CNT]
|
||||
WHILE (IGREATERP CNT 0) DO (\OUTCHAR DSTSTRM (\INCCODE.EOLC SRCSTRM NIL 'CNT CNT]
|
||||
T])
|
||||
|
||||
(COPYFILE
|
||||
@@ -2440,10 +2442,11 @@ update the map")
|
||||
OLDVAL])
|
||||
|
||||
(ACCESS-CHARSET
|
||||
[LAMBDA (STREAM NEWVALUE DONTMARKFILE) (* ; "Edited 8-Dec-2023 15:05 by rmk")
|
||||
[LAMBDA (STREAM NEWVALUE DONTMARKFILE) (* ; "Edited 24-Apr-2025 22:15 by rmk")
|
||||
(* ; "Edited 8-Dec-2023 15:05 by rmk")
|
||||
(* ; "Edited 11-Sep-87 15:46 by bvm:")
|
||||
|
||||
(* ;; "Unless DONTMARKSTREAM, if STREAM is open for output, the external format function may modify the backing file as well as the stream, e.g. put in XCCS shifting bytes.")
|
||||
(* ;; "Unless DONTMARKSTREAM, if STREAM is open for output, the external format function may modify the backing file as well as the stream, e.g. put in MCCS shifting bytes.")
|
||||
|
||||
(FDEVOP 'CHARSETFN (fetch (STREAM DEVICE) of STREAM)
|
||||
STREAM NEWVALUE DONTMARKFILE])
|
||||
@@ -2715,10 +2718,11 @@ update the map")
|
||||
(\BACKCCODE.EOLC STRM)))])])
|
||||
|
||||
(\GENERIC.CHARSET
|
||||
[LAMBDA (STREAM NEWVALUE DONTMARKSTREAM) (* ; "Edited 8-Dec-2023 15:17 by rmk")
|
||||
[LAMBDA (STREAM NEWVALUE DONTMARKSTREAM) (* ; "Edited 24-Apr-2025 22:16 by rmk")
|
||||
(* ; "Edited 8-Dec-2023 15:17 by rmk")
|
||||
(* ; "Edited 11-Sep-87 16:20 by bvm:")
|
||||
|
||||
(* ;;; "sets or returns the current numeric character set for this stream. This applies the stream's FORMATCHARSETFN if it has one, and (if MARKSTREAM) that may change an output backing stream in some way (e.g. write XCCS charset shift bytes). Otherwise, this just sets the charset stream parameter to influence subsequent reading and writing behavior. Charset doesn't exist in some formats (e.g. UTF-8), the format function would be a noop in that case.")
|
||||
(* ;;; "sets or returns the current numeric character set for this stream. This applies the stream's FORMATCHARSETFN if it has one, and (if MARKSTREAM) that may change an output backing stream in some way (e.g. write MCCS charset shift bytes). Otherwise, this just sets the charset stream parameter to influence subsequent reading and writing behavior. Charset doesn't exist in some formats (e.g. UTF-8), the format function would be a noop in that case.")
|
||||
|
||||
(\DTEST STREAM 'STREAM)
|
||||
(LET ((EFORMAT (ffetch (STREAM EXTERNALFORMAT) of STREAM))
|
||||
@@ -3162,39 +3166,39 @@ update the map")
|
||||
(ADDTOVAR LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (27735 31851 (STREAMPROP 27745 . 28179) (GETSTREAMPROP 28181 . 28930) (PUTSTREAMPROP
|
||||
28932 . 31699) (STREAMP 31701 . 31849)) (31894 35273 (\DEFPRINT.BY.NAME 31904 . 33056) (
|
||||
\STREAM.DEFPRINT 33058 . 34966) (\FDEV.DEFPRINT 34968 . 35271)) (35531 40572 (\GETACCESS 35541 . 35995
|
||||
) (\SETACCESS 35997 . 40570)) (60798 66767 (\DEFINEDEVICE 60808 . 63124) (\GETDEVICEFROMNAME 63126 .
|
||||
63599) (\GETDEVICEFROMHOSTNAME 63601 . 64645) (\REMOVEDEVICE 64647 . 65770) (\REMOVEDEVICE.NAMES 65772
|
||||
. 66765)) (66807 94538 (\CLOSEFILE 66817 . 67642) (\DELETEFILE 67644 . 67938) (\DEVICEEVENT 67940 .
|
||||
69710) (\GENERATEFILES 69712 . 70659) (\GENERATENEXTFILE 70661 . 71312) (\GENERATEFILEINFO 71314 .
|
||||
71775) (\GETFILENAME 71777 . 72166) (\GENERIC.OUTFILEP 72168 . 72638) (\OPENFILE 72640 . 75218) (
|
||||
\DO.PARAMS.AT.OPEN 75220 . 79416) (\RENAMEFILE 79418 . 80374) (\REVALIDATEFILE 80376 . 82978) (
|
||||
\PAGED.REVALIDATEFILELST 82980 . 84538) (\PAGED.REVALIDATEFILES 84540 . 86259) (\PAGED.REVALIDATEFILE
|
||||
86261 . 88544) (\BUFFERED.REVALIDATEFILE 88546 . 90832) (\BUFFERED.REVALIDATEFILELST 90834 . 92018) (
|
||||
\PRINT-REVALIDATION-RESULT 92020 . 92862) (\TRUNCATEFILE 92864 . 93255) (\FILE-CONFLICT 93257 . 94536)
|
||||
) (94574 99237 (\GENERATENOFILES 94584 . 96680) (\NULLFILEGENERATOR 96682 . 96926) (\NOFILESNEXTFILEFN
|
||||
96928 . 98919) (\NOFILESINFOFN 98921 . 99235)) (99356 101264 (\FILE.NOT.OPEN 99366 . 99879) (
|
||||
\FILE.WONT.OPEN 99881 . 100209) (\ILLEGAL.DEVICEOP 100211 . 100493) (\IS.NOT.RANDACCESSP 100495 .
|
||||
100941) (\STREAM.NOT.OPEN 100943 . 101262)) (101399 103697 (\FDEVINSTANCE 101409 . 103695)) (104899
|
||||
112273 (CNDIR 104909 . 106214) (DIRECTORYNAME 106216 . 110399) (DIRECTORYNAMEP 110401 . 111017) (
|
||||
HOSTNAMEP 111019 . 111826) (\ADD.CONNECTED.DIR 111828 . 112271)) (112318 140973 (\BACKFILEPTR 112328
|
||||
. 112516) (\BACKPEEKBIN 112518 . 112879) (\BACKBIN 112881 . 113232) (BIN 113234 . 113451) (\BIN
|
||||
113453 . 113730) (\BINS 113732 . 114018) (BOUT 114020 . 114382) (\BOUT 114384 . 114699) (\BOUTS 114701
|
||||
. 115012) (COPYBYTES 115014 . 118346) (COPYCHARS 118348 . 122014) (COPYFILE 122016 . 123325) (
|
||||
\COPYOPENFILE 123327 . 126526) (\INFER.FILE.TYPE 126528 . 127482) (EOFP 127484 . 127781) (FORCEOUTPUT
|
||||
127783 . 128030) (\FLUSH.OPEN.STREAMS 128032 . 128388) (CHARSET 128390 . 129749) (ACCESS-CHARSET
|
||||
129751 . 130279) (GETEOFPTR 130281 . 130531) (GETFILEINFO 130533 . 133726) (\TYPE.FROM.FILETYPE 133728
|
||||
. 134198) (\FILETYPE.FROM.TYPE 134200 . 134379) (GETFILEPTR 134381 . 134633) (SETFILEINFO 134635 .
|
||||
138872) (SETFILEPTR 138874 . 140593) (BOUT16 140595 . 140780) (BIN16 140782 . 140971)) (141076 148147
|
||||
(\GENERIC.BINS 141086 . 141366) (\GENERIC.BOUTS 141368 . 141633) (\GENERIC.RENAMEFILE 141635 . 143883)
|
||||
(\GENERIC.OPENP 143885 . 145200) (\GENERIC.READP 145202 . 146354) (\GENERIC.CHARSET 146356 . 148145))
|
||||
(148148 148487 (\MAP-OPEN-STREAMS 148158 . 148485)) (150342 152422 (\EOF.ACTION 150352 . 150603) (
|
||||
\EOSERROR 150605 . 150798) (\GETEOFPTR 150800 . 150982) (\INCFILEPTR 150984 . 151334) (\PEEKBIN 151336
|
||||
. 151527) (\SETCLOSEDFILELENGTH 151529 . 151863) (\SETEOFPTR 151865 . 152053) (\SETFILEPTR 152055 .
|
||||
152420)) (152423 152965 (\FIXPOUT 152433 . 152733) (\FIXPIN 152735 . 152963)) (152966 153532 (\BOUTEOL
|
||||
152976 . 153530)) (156428 166292 (\BUFFERED.BIN 156438 . 157290) (\BUFFERED.PEEKBIN 157292 . 158074)
|
||||
(\BUFFERED.BOUT 158076 . 158936) (\BUFFERED.BINS 158938 . 162623) (\BUFFERED.BOUTS 162625 . 164426) (
|
||||
\BUFFERED.COPYBYTES 164428 . 166290)))))
|
||||
(FILEMAP (NIL (27784 31900 (STREAMPROP 27794 . 28228) (GETSTREAMPROP 28230 . 28979) (PUTSTREAMPROP
|
||||
28981 . 31748) (STREAMP 31750 . 31898)) (31943 35322 (\DEFPRINT.BY.NAME 31953 . 33105) (
|
||||
\STREAM.DEFPRINT 33107 . 35015) (\FDEV.DEFPRINT 35017 . 35320)) (35580 40621 (\GETACCESS 35590 . 36044
|
||||
) (\SETACCESS 36046 . 40619)) (60847 66816 (\DEFINEDEVICE 60857 . 63173) (\GETDEVICEFROMNAME 63175 .
|
||||
63648) (\GETDEVICEFROMHOSTNAME 63650 . 64694) (\REMOVEDEVICE 64696 . 65819) (\REMOVEDEVICE.NAMES 65821
|
||||
. 66814)) (66856 94587 (\CLOSEFILE 66866 . 67691) (\DELETEFILE 67693 . 67987) (\DEVICEEVENT 67989 .
|
||||
69759) (\GENERATEFILES 69761 . 70708) (\GENERATENEXTFILE 70710 . 71361) (\GENERATEFILEINFO 71363 .
|
||||
71824) (\GETFILENAME 71826 . 72215) (\GENERIC.OUTFILEP 72217 . 72687) (\OPENFILE 72689 . 75267) (
|
||||
\DO.PARAMS.AT.OPEN 75269 . 79465) (\RENAMEFILE 79467 . 80423) (\REVALIDATEFILE 80425 . 83027) (
|
||||
\PAGED.REVALIDATEFILELST 83029 . 84587) (\PAGED.REVALIDATEFILES 84589 . 86308) (\PAGED.REVALIDATEFILE
|
||||
86310 . 88593) (\BUFFERED.REVALIDATEFILE 88595 . 90881) (\BUFFERED.REVALIDATEFILELST 90883 . 92067) (
|
||||
\PRINT-REVALIDATION-RESULT 92069 . 92911) (\TRUNCATEFILE 92913 . 93304) (\FILE-CONFLICT 93306 . 94585)
|
||||
) (94623 99286 (\GENERATENOFILES 94633 . 96729) (\NULLFILEGENERATOR 96731 . 96975) (\NOFILESNEXTFILEFN
|
||||
96977 . 98968) (\NOFILESINFOFN 98970 . 99284)) (99405 101313 (\FILE.NOT.OPEN 99415 . 99928) (
|
||||
\FILE.WONT.OPEN 99930 . 100258) (\ILLEGAL.DEVICEOP 100260 . 100542) (\IS.NOT.RANDACCESSP 100544 .
|
||||
100990) (\STREAM.NOT.OPEN 100992 . 101311)) (101448 103746 (\FDEVINSTANCE 101458 . 103744)) (104948
|
||||
112322 (CNDIR 104958 . 106263) (DIRECTORYNAME 106265 . 110448) (DIRECTORYNAMEP 110450 . 111066) (
|
||||
HOSTNAMEP 111068 . 111875) (\ADD.CONNECTED.DIR 111877 . 112320)) (112367 141263 (\BACKFILEPTR 112377
|
||||
. 112565) (\BACKPEEKBIN 112567 . 112928) (\BACKBIN 112930 . 113281) (BIN 113283 . 113500) (\BIN
|
||||
113502 . 113779) (\BINS 113781 . 114067) (BOUT 114069 . 114431) (\BOUT 114433 . 114748) (\BOUTS 114750
|
||||
. 115061) (COPYBYTES 115063 . 118395) (COPYCHARS 118397 . 122195) (COPYFILE 122197 . 123506) (
|
||||
\COPYOPENFILE 123508 . 126707) (\INFER.FILE.TYPE 126709 . 127663) (EOFP 127665 . 127962) (FORCEOUTPUT
|
||||
127964 . 128211) (\FLUSH.OPEN.STREAMS 128213 . 128569) (CHARSET 128571 . 129930) (ACCESS-CHARSET
|
||||
129932 . 130569) (GETEOFPTR 130571 . 130821) (GETFILEINFO 130823 . 134016) (\TYPE.FROM.FILETYPE 134018
|
||||
. 134488) (\FILETYPE.FROM.TYPE 134490 . 134669) (GETFILEPTR 134671 . 134923) (SETFILEINFO 134925 .
|
||||
139162) (SETFILEPTR 139164 . 140883) (BOUT16 140885 . 141070) (BIN16 141072 . 141261)) (141366 148546
|
||||
(\GENERIC.BINS 141376 . 141656) (\GENERIC.BOUTS 141658 . 141923) (\GENERIC.RENAMEFILE 141925 . 144173)
|
||||
(\GENERIC.OPENP 144175 . 145490) (\GENERIC.READP 145492 . 146644) (\GENERIC.CHARSET 146646 . 148544))
|
||||
(148547 148886 (\MAP-OPEN-STREAMS 148557 . 148884)) (150741 152821 (\EOF.ACTION 150751 . 151002) (
|
||||
\EOSERROR 151004 . 151197) (\GETEOFPTR 151199 . 151381) (\INCFILEPTR 151383 . 151733) (\PEEKBIN 151735
|
||||
. 151926) (\SETCLOSEDFILELENGTH 151928 . 152262) (\SETEOFPTR 152264 . 152452) (\SETFILEPTR 152454 .
|
||||
152819)) (152822 153364 (\FIXPOUT 152832 . 153132) (\FIXPIN 153134 . 153362)) (153365 153931 (\BOUTEOL
|
||||
153375 . 153929)) (156827 166691 (\BUFFERED.BIN 156837 . 157689) (\BUFFERED.PEEKBIN 157691 . 158473)
|
||||
(\BUFFERED.BOUT 158475 . 159335) (\BUFFERED.BINS 159337 . 163022) (\BUFFERED.BOUTS 163024 . 164825) (
|
||||
\BUFFERED.COPYBYTES 164827 . 166689)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
881
sources/HARDCOPY
881
sources/HARDCOPY
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Reference in New Issue
Block a user