Compare commits
11 Commits
mth63--Mis
...
rmk180--Mo
| Author | SHA1 | Date | |
|---|---|---|---|
|
c1d9b9eb33 | ||
|
4e761298ea | ||
|
cbea9a7c9d | ||
|
47dd8edf60 | ||
|
|
1d2292aa62 | ||
|
4499b4d914 | ||
|
|
0317fbd882 | ||
|
|
b0c6136bd6 | ||
|
|
d922212de1 | ||
|
|
96c609e5f0 | ||
|
|
fb0af3c05f |
@@ -1,27 +1,29 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "28-Jan-2026 11:03:17" {DSK}<Users>larry>il>medley>internal>MEDLEY-UTILS.;3 26880
|
||||
(FILECREATED "16-Apr-2026 22:42:51" {DSK}<home>matt>Interlisp>medley>internal>MEDLEY-UTILS.;2 30564
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (FNS MAKE-INDEX-HTMLS GATHER-INFO MAKE-FULLER-DB MEDLEY-FIX-LINKS MEDLEY-FIX-DATES
|
||||
MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH MAKE-WHEREIS-LOOPS HCFILES RECOMPILE-ONE
|
||||
RECMPL COMPILE-SETUP REMAKEFILES)
|
||||
:CHANGES-TO (FNS HCFILES MAKE-EXPORTS-ALL MAKE-INDEX-HTMLS)
|
||||
(FUNCTIONS REPORT-AND-GO)
|
||||
(VARS MEDLEY-UTILSCOMS HC-SKIP-EXTENSIONS)
|
||||
(ADVICE TEDIT.PROMPTPRINT)
|
||||
|
||||
:PREVIOUS-DATE "28-Jan-2026 10:46:02" {DSK}<Users>larry>il>medley>internal>MEDLEY-UTILS.;1)
|
||||
:PREVIOUS-DATE "16-Apr-2026 22:27:40" {DSK}<home>matt>Interlisp>medley>internal>MEDLEY-UTILS.;1
|
||||
)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEY-UTILSCOMS)
|
||||
|
||||
(RPAQQ MEDLEY-UTILSCOMS
|
||||
[(FNS GATHER-INFO MAKE-FULLER-DB MEDLEY-FIX-LINKS MEDLEY-FIX-DATES)
|
||||
(VARS MEDLEY-FIX-DIRS OKSOURCES OKLIBRARY OKLISPUSERS OKINTERNAL)
|
||||
(VARS HC-SKIP-EXTENSIONS MEDLEY-FIX-DIRS OKSOURCES OKLIBRARY OKLISPUSERS OKINTERNAL)
|
||||
(FNS MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH MAKE-WHEREIS-LOOPS)
|
||||
(FNS HCFILES MAKE-INDEX-HTMLS)
|
||||
(PROP FILETYPE MEDLEY-UTILS)
|
||||
(ADVISE TEDIT.PROMPTPRINT)
|
||||
(FNS RECOMPILE-ONE RECMPL COMPILE-SETUP REMAKEFILES)
|
||||
(FUNCTIONS REPORT-AND-GO)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA])
|
||||
@@ -140,6 +142,12 @@
|
||||
(for X in (OR DIRS MEDLEY-FIX-DIRS) join (FIX-DIRECTORY-DATES (MEDLEYDIR (PRINT X T])
|
||||
)
|
||||
|
||||
(RPAQQ HC-SKIP-EXTENSIONS
|
||||
(PDF SKIP HTML LCOM DFASL SH SYSOUT DRIBBLE IMPTR DISPLAYFONT WD WIDTHS MEDLEYDISPLAYFONT
|
||||
PSCFONT ALL DATABASE 1 MD GZ PRESS IP BITMAP EL ELC XFORMS BUGREPORTS SUITE LISTING AWK
|
||||
DINFOGRAPH HASHFILE BLTCHAR DOC DOCPOINTERS STATUS NOTEFILE ICO ISS BMP PNG PS1
|
||||
VENUESYSOUT ACE FMC HKB LGC CMD COMMAND HTM SVG XML EXE))
|
||||
|
||||
(RPAQQ MEDLEY-FIX-DIRS ("sources" "library" "lispusers" "internal" "greetfiles" "doctools"))
|
||||
|
||||
(RPAQQ OKSOURCES (RENAMEFNS VMEM READSYS CASH-FILE HASH-FILE MEDLEYDIR MAKEINIT))
|
||||
@@ -162,15 +170,18 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-EXPORTS-ALL
|
||||
[LAMBDA (OUTFILE) (* ; "Edited 3-Aug-2023 18:34 by frank")
|
||||
[LAMBDA (OUTFILE) (* ; "Edited 15-Apr-2026 16:42 by mth")
|
||||
(* ; "Edited 3-Aug-2023 18:34 by frank")
|
||||
(* ; "Edited 9-Mar-2021 16:11 by larry")
|
||||
(* "Edited May 3, 2018 by Ron Kaplan--relative to MEDLEYDIR/lispcore/. Don't know why it does the CORE/RENAME")
|
||||
(*
|
||||
"Edited Aug 17 94 by Sybalsky -- point it to /king/export/lispcore as the truth directory.")
|
||||
(*
|
||||
"Edited July 5, 1990 by Sybalsky -- point it to Pele as the truth directory.")
|
||||
(*
|
||||
"Edited September 29, 1986 by van Melle")
|
||||
|
||||
(* ;; "Edited May 3, 2018 by Ron Kaplan--relative to MEDLEYDIR/lispcore/. Don't know why it does the CORE/RENAME")
|
||||
|
||||
(* ;; "Edited Aug 17 94 by Sybalsky -- point it to /king/export/lispcore as the truth directory.")
|
||||
|
||||
(* ;; "Edited July 5, 1990 by Sybalsky -- point it to Pele as the truth directory.")
|
||||
|
||||
(* ;; "Edited September 29, 1986 by van Melle")
|
||||
|
||||
(CNDIR (MEDLEYDIR "sources"))
|
||||
(LOAD 'FILESETS)
|
||||
(GATHEREXPORTS EXPORTFILES (OR OUTFILE "exports.all"])
|
||||
@@ -204,7 +215,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(HCFILES
|
||||
[LAMBDA (BASE REDO SUBSETS) (* ; "Edited 30-Jun-2024 08:27 by lmm")
|
||||
[LAMBDA (BASE REDO SUBSETS) (* ; "Edited 16-Apr-2026 22:42 by mth")
|
||||
(* ; "Edited 30-Jun-2024 08:27 by lmm")
|
||||
(* ; "Edited 23-Apr-2024 23:15 by lmm")
|
||||
(* ; "Edited 22-Apr-2024 13:22 by lmm")
|
||||
(* ; "Edited 5-Feb-2024 12:16 by lmm")
|
||||
@@ -213,74 +225,116 @@
|
||||
|
||||
(* ;;;; "BASE is the root directory. Doesn't replace PDF files except when REDO")
|
||||
|
||||
(* ;;; " SUBSETS is some combinsyion og (:YRDY :HYML :PRETTY and INDEX")
|
||||
(* ;;; " SUBSETS is some combination of (:YRDY :HYML :PRETTY and INDEX")
|
||||
|
||||
(LET
|
||||
[[DIRLIST (LIST (OR BASE (PSEUDOFILENAME (MEDLEYDIR]
|
||||
(PHASES (OR SUBSETS '(TEDIT PRETTY INDEX HRULE]
|
||||
(FILESLOAD PDFSTREAM SKETCH)
|
||||
(FONTSET 'STANDARD)
|
||||
(while DIRLIST
|
||||
do
|
||||
(SETQ BASE (pop DIRLIST))
|
||||
(for SRCPATH in (DIRECTORY (CONCAT BASE "*.*;"))
|
||||
do (PROG* [(SRC (UNPACKFILENAME SRCPATH))
|
||||
[EXT (U-CASE (LISTGET SRC 'EXTENSION]
|
||||
(DIR (LISTGET SRC 'DIRECTORY))
|
||||
FRDY LDGP DEST (NOV (PACKFILENAME `(VERSION NIL ,@SRC]
|
||||
(CL:FORMAT T "Starting on ~a :~%%" SRCPATH)
|
||||
(CL:WHEN (DIRECTORYNAMEP SRCPATH)
|
||||
(LET* ([DIRLIST (LIST (OR BASE (PSEUDOFILENAME (MEDLEYDIR]
|
||||
[PHASES (OR SUBSETS '(TEDIT PRETTY INDEX HRULE]
|
||||
(DOTEDIT (MEMB 'TEDIT PHASES))
|
||||
(DOPRETTY (MEMB 'PRETTY PHASES)))
|
||||
(FILESLOAD PDFSTREAM SKETCH)
|
||||
(FONTSET 'STANDARD)
|
||||
(while DIRLIST
|
||||
do (SETQ BASE (pop DIRLIST))
|
||||
|
||||
(* ;; "any directory names, push them off and do them in another phase")
|
||||
(* ;; "Breadth-first processing")
|
||||
|
||||
(CL:UNLESS (OR (STRPOS ">." NOV)
|
||||
(INFILEP (CONCAT NOV ".skip")))
|
||||
(SETQ DIRLIST (NCONC1 DIRLIST SRCPATH)))
|
||||
(RETURN))
|
||||
(CL:WHEN
|
||||
(MEMB EXT
|
||||
'(PDF SKIP HTML LCOM DFASL SH SYSOUT DRIBBLE IMPTR DISPLAYFONT ALL
|
||||
DATABASE))
|
||||
(for SRCPATH in (DIRECTORY (CONCAT BASE "*.*;"))
|
||||
do (PROG* ((SRC (UNPACKFILENAME SRCPATH))
|
||||
[EXT (U-CASE (LISTGET SRC 'EXTENSION]
|
||||
(DIR (LISTGET SRC 'DIRECTORY))
|
||||
[NAME (U-CASE (LISTGET SRC 'NAME]
|
||||
[NOV (PACKFILENAME.STRING `(VERSION NIL ,@SRC]
|
||||
LSFP DEST)
|
||||
(CL:WHEN (DIRECTORYNAMEP SRCPATH)
|
||||
|
||||
(* ;; "ignore any of these extensions")
|
||||
(* ;;
|
||||
"any directory names, push them off and do them in another phase")
|
||||
|
||||
(RETURN))
|
||||
(if [NOT (OR (STRPOS "<." NOV)
|
||||
(CL:SEARCH "<LOADUPS>" NOV :TEST #'CL:CHAR-EQUAL)
|
||||
(STRPOS ">." NOV)
|
||||
(INFILEP (CONCAT NOV ".skip"]
|
||||
then (SETQ DIRLIST (NCONC1 DIRLIST SRCPATH))
|
||||
(CL:FORMAT T "~&Deferring to later ~a~%%" SRCPATH)
|
||||
else (CL:FORMAT T "~&Skipping ~a~%%" SRCPATH))
|
||||
(RETURN))
|
||||
|
||||
(* ;;
|
||||
" doesnt (yet) implement / to - translattion. .readme should show up as -.readme.")
|
||||
(* ;; "Fixup files that start with . and have no other extension")
|
||||
|
||||
(SETQ DEST (CONCAT NOV ".pdf"))
|
||||
(CL:WHEN (AND (NOT REDO)
|
||||
(INFILEP DEST))
|
||||
(CL:FORMAT T "~a already there~%%" DEST)
|
||||
(RETURN))
|
||||
(CL:WHEN (INFILEP (CONCAT DEST ".skip"))
|
||||
(PRINTOUT T "Explicit .skip " DEST T)
|
||||
(RETURN))
|
||||
(if (MEMB 'TEDIT PHASES)
|
||||
then (CL:WHEN [OR (MEMB EXT '(TEDIT TED SKETCH BRAVO))
|
||||
(CAR (NLSETQ (TEDIT.FORMATTEDFILEP SRCPATH]
|
||||
(if (EQ REDO 'TEST)
|
||||
then (CL:FORMAT T "Testing open ~a..." SRCPATH)
|
||||
(CLOSEF? (OPENTEXTSTREAM SRCPATH))
|
||||
else (OR [NLSETQ (CL:WITH-OPEN-STREAM (S (OPENTEXTSTREAM SRCPATH)
|
||||
)
|
||||
(TEDIT.FORMAT.HARDCOPY S DEST T NIL NIL
|
||||
NIL 'PDF]
|
||||
(PRINT 'FAIL T)))
|
||||
(CL:FORMAT T "DONE")))
|
||||
(CL:WHEN (AND (MEMB 'PRETTY PHASES)
|
||||
(MEMB EXT '(NIL IL))
|
||||
[SETQ LSFP (CAR (NLSETQ (LISPSOURCEFILEP SRCPATH]
|
||||
(NEQ LSFP *COMMON-LISP-READ-ENVIRONMENT*))
|
||||
(PRINTOUT T "PDF printing " " to " DEST "...")
|
||||
(OR (NLSETQ (CL:WITH-OPEN-STREAM (STR (OPEN-PDF-STREAM DEST))
|
||||
(PRETTYFILEINDEX SRCPATH NIL STR)))
|
||||
(PRINT 'FAIL T))
|
||||
(PRINTOUT T "DONE" T))])
|
||||
(CL:WHEN (AND (NULL EXT)
|
||||
(EQ (CHCON1 NAME)
|
||||
(CHARCODE %.)))
|
||||
(SETQ EXT (SUBATOM NAME 2)))
|
||||
(CL:WHEN (MEMB EXT HC-SKIP-EXTENSIONS)
|
||||
|
||||
(* ;; "ignore any of these extensions")
|
||||
|
||||
(CL:FORMAT T "~&Ignoring (on extension): ~a~%%" SRCPATH)
|
||||
(RETURN))
|
||||
|
||||
(* ;;
|
||||
" doesn't (yet) implement / to - translation. .readme should show up as -.readme.")
|
||||
|
||||
(SETQ DEST (CONCAT NOV ".pdf"))
|
||||
(CL:WHEN (AND (NOT REDO)
|
||||
(INFILEP DEST))
|
||||
(CL:FORMAT T "~a is already there~%%" DEST)
|
||||
(RETURN))
|
||||
(CL:WHEN (INFILEP (CONCAT DEST ".skip"))
|
||||
(CL:FORMAT T "Explicit .skip ~a~%%" DEST)
|
||||
(RETURN))
|
||||
(CL:FORMAT T "~&Starting on ~a:~%%" SRCPATH)
|
||||
(CL:WHEN [AND DOTEDIT (OR (MEMB EXT '(TEDIT TED SKETCH BRAVO))
|
||||
(CAR (REPORT-AND-GO (TEDIT.FORMATTEDFILEP
|
||||
SRCPATH)
|
||||
(CL:FORMAT NIL
|
||||
"~~%%~S TEDIT.FORMATTEDFILEP of ~A -- Condition: ~~A"
|
||||
'FAIL SRCPATH]
|
||||
(if (EQ REDO 'TEST)
|
||||
then (CL:FORMAT T "Testing open ~a..." SRCPATH)
|
||||
(CLOSEF? (OPENTEXTSTREAM SRCPATH))
|
||||
else (REPORT-AND-GO (CL:WITH-OPEN-STREAM (S (OPENTEXTSTREAM
|
||||
SRCPATH))
|
||||
(TEDIT.FORMAT.HARDCOPY S DEST T NIL NIL
|
||||
NIL 'PDF))
|
||||
(CL:FORMAT NIL
|
||||
"~~%%~S TEDIT.FORMAT.HARDCOPY of ~A -- Condition: ~~A"
|
||||
'FAIL SRCPATH)))
|
||||
(PRIN3 " DONE" T)
|
||||
(TERPRI T)
|
||||
(RETURN))
|
||||
(CL:WHEN (AND DOPRETTY (OR (NULL EXT)
|
||||
(EQ EXT 'IL))
|
||||
[SETQ LSFP (CAR (REPORT-AND-GO (LISPSOURCEFILEP SRCPATH)
|
||||
(CL:FORMAT NIL
|
||||
"~~%%~S LISPSOURCEFILEP of ~A -- Condition: ~~A"
|
||||
'FAIL SRCPATH]
|
||||
(NEQ LSFP *COMMON-LISP-READ-ENVIRONMENT*))
|
||||
|
||||
(* ;; "Why the check for NEQ *COMMON-LISP-READ-ENVIRONMENT* ??")
|
||||
|
||||
(PRIN3 "PDF printing " T)
|
||||
(PRIN3 SRCPATH T)
|
||||
(PRIN3 " to " T)
|
||||
(PRIN3 DEST T)
|
||||
(PRIN3 " ..." T)
|
||||
(REPORT-AND-GO (CL:WITH-OPEN-STREAM (STR (OPEN-PDF-STREAM DEST))
|
||||
(PRETTYFILEINDEX SRCPATH NIL STR))
|
||||
(CL:FORMAT NIL
|
||||
"~~%%~S PRETTYFILEINDEX of ~A -- Condition: ~~A"
|
||||
'FAIL SRCPATH))
|
||||
(PRIN3 " DONE" T)
|
||||
(TERPRI T)
|
||||
(RETURN))
|
||||
|
||||
(* ;; "Everything else")
|
||||
|
||||
(PRIN3 "No processing." T)
|
||||
(TERPRI T])
|
||||
|
||||
(MAKE-INDEX-HTMLS
|
||||
[LAMBDA (BASE TOP LEVEL ROOT.NAME) (* ; "Edited 28-Jan-2026 11:01 by lmm")
|
||||
[LAMBDA (BASE TOP LEVEL ROOT.NAME) (* ; "Edited 15-Apr-2026 16:33 by mth")
|
||||
(* ; "Edited 28-Jan-2026 11:01 by lmm")
|
||||
(* ; "Edited 27-Jan-2026 10:50 by lmm")
|
||||
(* ; "Edited 23-Jan-2026 11:59 by lmm")
|
||||
(* ; "Edited 29-Apr-2024 14:18 by lmm")
|
||||
@@ -339,8 +393,8 @@
|
||||
then 2
|
||||
else 1))
|
||||
-2)))
|
||||
(CL:UNLESS (OR (MEMB SHORTNAME '(.git))
|
||||
(MEMB SHORTNAME '(.GIT))
|
||||
(CL:UNLESS (OR (EQ SHORTNAME '.git)
|
||||
(EQ SHORTNAME '.GIT)
|
||||
[AND (STRPOS ".git" (L-CASE FULLNAME))
|
||||
(NOT (STRPOS ".github" (L-CASE FULLNAME]
|
||||
(INFILEP (CONCAT FULLNAME ".skip")))
|
||||
@@ -372,7 +426,8 @@
|
||||
|
||||
(PUTPROPS MEDLEY-UTILS FILETYPE :COMPILE-FILE)
|
||||
|
||||
[XCL:REINSTALL-ADVICE 'TEDIT.PROMPTPRINT :BEFORE '((:LAST (PRIN1 MSG T)))
|
||||
[XCL:REINSTALL-ADVICE 'TEDIT.PROMPTPRINT :BEFORE '[(:LAST (PROGN (PRIN3 " " T)
|
||||
(PRIN3 MSG T]
|
||||
:AFTER
|
||||
'((:LAST (AND (STRPOS "GETFN" MSG)
|
||||
(HELP MSG]
|
||||
@@ -463,6 +518,15 @@
|
||||
(SETQ DIFF (COMPARESOURCES X DESTFILE NIL))
|
||||
(TERPRI])
|
||||
)
|
||||
|
||||
(DEFMACRO REPORT-AND-GO (FORM REPORT-FORMAT) (* ; "Edited 16-Apr-2026 16:02 by mth")
|
||||
`[CL:MULTIPLE-VALUE-BIND (FORM-RESULT ERROR-CONDITION)
|
||||
(IGNORE-ERRORS (CL:VALUES ,FORM)) (* ; "Only the first value")
|
||||
(COND
|
||||
(ERROR-CONDITION (PRIN3 (CL:FORMAT NIL ,REPORT-FORMAT ERROR-CONDITION)
|
||||
T)
|
||||
NIL)
|
||||
(T (LIST FORM-RESULT])
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
@@ -472,9 +536,10 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1312 8246 (GATHER-INFO 1322 . 6704) (MAKE-FULLER-DB 6706 . 7615) (MEDLEY-FIX-LINKS 7617
|
||||
. 8010) (MEDLEY-FIX-DATES 8012 . 8244)) (9425 12213 (MAKE-EXPORTS-ALL 9435 . 10494) (
|
||||
MAKE-WHEREIS-HASH 10496 . 11685) (MAKE-WHEREIS-LOOPS 11687 . 12211)) (12214 21862 (HCFILES 12224 .
|
||||
16487) (MAKE-INDEX-HTMLS 16489 . 21860)) (22112 26724 (RECOMPILE-ONE 22122 . 24019) (RECMPL 24021 .
|
||||
24624) (COMPILE-SETUP 24626 . 25250) (REMAKEFILES 25252 . 26722)))))
|
||||
(FILEMAP (NIL (1289 8223 (GATHER-INFO 1299 . 6681) (MAKE-FULLER-DB 6683 . 7592) (MEDLEY-FIX-LINKS 7594
|
||||
. 7987) (MEDLEY-FIX-DATES 7989 . 8221)) (9795 12371 (MAKE-EXPORTS-ALL 9805 . 10652) (
|
||||
MAKE-WHEREIS-HASH 10654 . 11843) (MAKE-WHEREIS-LOOPS 11845 . 12369)) (12372 24990 (HCFILES 12382 .
|
||||
19514) (MAKE-INDEX-HTMLS 19516 . 24988)) (25324 29936 (RECOMPILE-ONE 25334 . 27231) (RECMPL 27233 .
|
||||
27836) (COMPILE-SETUP 27838 . 28462) (REMAKEFILES 28464 . 29934)) (29938 30408 (REPORT-AND-GO 29938 .
|
||||
30408)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
317
library/GRAPHER
317
library/GRAPHER
@@ -1,21 +1,18 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "14-Mar-2021 20:40:30"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>GRAPHER.;5 214171
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
changes to%: (VARS GRAPHERCOMS)
|
||||
(FILECREATED "14-Apr-2026 22:19:19" {DSK}<home>frank>il>medley>library>GRAPHER.;3 215302
|
||||
|
||||
previous date%: "14-May-2018 10:24:38"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>GRAPHER.;4)
|
||||
:EDIT-BY "FGH"
|
||||
|
||||
:CHANGES-TO (FNS DISPLAYLINK/RL DISPLAYLINK/LR DISPLAYLINK/BT DISPLAYLINK/TB)
|
||||
|
||||
:PREVIOUS-DATE "14-Mar-2021 20:40:30" {DSK}<home>frank>il>medley>library>GRAPHER.;1)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1983-1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT GRAPHERCOMS)
|
||||
|
||||
(RPAQQ GRAPHERCOMS
|
||||
[(COMS (* ; "Graph Editing")
|
||||
[(COMS (* ; "Graph Editing")
|
||||
(FNS ADD/AND/DISPLAY/LINK APPLYTOSELECTEDNODE CALL.MOVENODEFN CHANGE.NODEFONT.SIZE
|
||||
DEFAULT.ADDNODEFN DELETE/AND/DISPLAY/LINK DISPLAY/NAME DISPLAYGRAPH DISPLAYLINK
|
||||
DISPLAYLINK/BT DISPLAYLINK/LR DISPLAYLINK/RL DISPLAYLINK/TB DISPLAYNODE
|
||||
@@ -38,18 +35,18 @@ Copyright (c) 1983-1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN (GETD 'MODERNWINDOW.SETUP)
|
||||
(MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE))]
|
||||
|
||||
(* ;; "Support for EDITSUBGRAPH and EDITREGION")
|
||||
(* ;; "Support for EDITSUBGRAPH and EDITREGION")
|
||||
|
||||
(FNS EDITMOVEREGION EDITMOVESUBTREE NOT.TRACKCURSOR RECURSIVE.COLLECTDESCENDENTS
|
||||
MOVEDESCENDENTS COLLECT.CHILD.NODES CREATE.NEW.NODEPOSITION
|
||||
GETBOXPOSITION.FROMINITIALREGION COLLECTDESCENDENTS))
|
||||
(COMS (* ;
|
||||
"functions for finding larger and smaller fonts")
|
||||
(COMS (* ;
|
||||
"functions for finding larger and smaller fonts")
|
||||
(FNS NEXTSIZEFONT DECREASING.FONT.LIST SCALE.FONT)
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DECREASING.FONT.LIST (DECREASING.FONT.LIST]
|
||||
(GLOBALVARS DECREASING.FONT.LIST))
|
||||
(* ;
|
||||
"functions for LAYOUTGRAPH And LAYOUTLATTICE")
|
||||
(* ;
|
||||
"functions for LAYOUTGRAPH And LAYOUTLATTICE")
|
||||
(FNS BRH/LAYOUT BRH/LAYOUT/DAUGHTERS BRH/OFFSET BRHC/INTERTREE/SPACE BRHC/LAYOUT
|
||||
BRHC/LAYOUT/DAUGHTERS BRHC/LAYOUT/TERMINAL BRHC/OFFSET BRHL/LAYOUT BRHL/LAYOUT/DAUGHTERS
|
||||
BRHL/MOVE/RIGHT BROWSE/LAYOUT/HORIZ BROWSE/LAYOUT/HORIZ/COMPACTLY BROWSE/LAYOUT/LATTICE
|
||||
@@ -95,7 +92,7 @@ Copyright (c) 1983-1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(LOCALVARS . T)
|
||||
(RECORDS GRAPHNODE GRAPH)
|
||||
(DECLARE%: DONTCOPY (MACROS HALF))
|
||||
(COMS (* ; "Grapher image objects")
|
||||
(COMS (* ; "Grapher image objects")
|
||||
(FNS GRAPHERIMAGEFNS)
|
||||
(FNS GRAPHERCOPYBUTTONEVENTFN GRAPHOBJ.FINDGRAPH)
|
||||
(FNS ALIGNMENTNODE GRAPHOBJ.CHECKALIGN)
|
||||
@@ -303,96 +300,112 @@ Copyright (c) 1983-1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
NIL])
|
||||
|
||||
(DISPLAYLINK/BT
|
||||
[LAMBDA (TRANS GNB GNT WIDTH OPERATION STREAM PARAMS)
|
||||
[LAMBDA (TRANS GNB GNT WIDTH OPERATION STREAM PARAMS) (* ; "Edited 14-Apr-2026 22:08 by FGH")
|
||||
(* ; "Edited 29-Apr-94 13:59 by sybalsky")
|
||||
|
||||
(* draws a line from the bottom edge of GNB to the top edge of GNT translated
|
||||
by TRANS)
|
||||
(* draws a line from the bottom edge of GNB to the top edge of GNT translated by
|
||||
TRANS)
|
||||
|
||||
(APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN)
|
||||
'DRAWLINE)
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(SUB1 (GN/BOTTOM GNB)))
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(ADD1 (GN/TOP GNT)))
|
||||
(OR (LISTGET PARAMS 'LINEWIDTH)
|
||||
WIDTH 1)
|
||||
OPERATION STREAM (LISTGET PARAMS 'COLOR)
|
||||
(LISTGET PARAMS 'DASHING)
|
||||
PARAMS])
|
||||
(LET* [(FN (LISTGET PARAMS 'DRAWLINKFN))
|
||||
(DFN (AND FN (GETD FN]
|
||||
(if (AND FN (NOT DFN))
|
||||
then (PROMPTPRINT (CONCAT "DISPLAYLINK: DRAWLINKFN " FN " NOT FOUND")))
|
||||
(APPLY* (OR (AND DFN FN)
|
||||
'DRAWLINE)
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(SUB1 (GN/BOTTOM GNB)))
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(ADD1 (GN/TOP GNT)))
|
||||
(OR (LISTGET PARAMS 'LINEWIDTH)
|
||||
WIDTH 1)
|
||||
OPERATION STREAM (LISTGET PARAMS 'COLOR)
|
||||
(LISTGET PARAMS 'DASHING)
|
||||
PARAMS])
|
||||
|
||||
(DISPLAYLINK/LR
|
||||
[LAMBDA (TRANS GNL GNR WIDTH OPERATION STREAM PARAMS)
|
||||
[LAMBDA (TRANS GNL GNR WIDTH OPERATION STREAM PARAMS) (* ; "Edited 14-Apr-2026 22:09 by FGH")
|
||||
(* ; "Edited 29-Apr-94 13:59 by sybalsky")
|
||||
|
||||
(* draws a line from the left edge of GNL to the right edge of GNR, translated
|
||||
by TRANS)
|
||||
(* draws a line from the left edge of GNL to the right edge of GNR, translated by
|
||||
TRANS)
|
||||
|
||||
(APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN)
|
||||
'DRAWLINE)
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(SUB1 (GN/LEFT GNL)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL)))
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(ADD1 (GN/RIGHT GNR)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR)))
|
||||
(OR (LISTGET PARAMS 'LINEWIDTH)
|
||||
WIDTH 1)
|
||||
OPERATION STREAM (LISTGET PARAMS 'COLOR)
|
||||
(LISTGET PARAMS 'DASHING)
|
||||
PARAMS])
|
||||
(LET* [(FN (LISTGET PARAMS 'DRAWLINKFN))
|
||||
(DFN (AND FN (GETD FN]
|
||||
(if (AND FN (NOT DFN))
|
||||
then (PROMPTPRINT (CONCAT "DISPLAYLINK: DRAWLINKFN " FN " NOT FOUND")))
|
||||
(APPLY* (OR (AND DFN FN)
|
||||
'DRAWLINE)
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(SUB1 (GN/LEFT GNL)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL)))
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(ADD1 (GN/RIGHT GNR)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR)))
|
||||
(OR (LISTGET PARAMS 'LINEWIDTH)
|
||||
WIDTH 1)
|
||||
OPERATION STREAM (LISTGET PARAMS 'COLOR)
|
||||
(LISTGET PARAMS 'DASHING)
|
||||
PARAMS])
|
||||
|
||||
(DISPLAYLINK/RL
|
||||
[LAMBDA (TRANS GNR GNL WIDTH OPERATION STREAM PARAMS)
|
||||
[LAMBDA (TRANS GNR GNL WIDTH OPERATION STREAM PARAMS) (* ; "Edited 14-Apr-2026 22:09 by FGH")
|
||||
(* ; "Edited 29-Apr-94 13:59 by sybalsky")
|
||||
|
||||
(* draws a line from the right edge of GNR, to the left edge of GNL translated
|
||||
by TRANS)
|
||||
(* draws a line from the right edge of GNR, to the left edge of GNL translated by
|
||||
TRANS)
|
||||
|
||||
(APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN)
|
||||
'DRAWLINE)
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(ADD1 (GN/RIGHT GNR)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR)))
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(SUB1 (GN/LEFT GNL)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL)))
|
||||
(OR (LISTGET PARAMS 'LINEWIDTH)
|
||||
WIDTH 1)
|
||||
OPERATION STREAM (LISTGET PARAMS 'COLOR)
|
||||
(LISTGET PARAMS 'DASHING)
|
||||
PARAMS])
|
||||
(LET* [(FN (LISTGET PARAMS 'DRAWLINKFN))
|
||||
(DFN (AND FN (GETD FN]
|
||||
(if (AND FN (NOT DFN))
|
||||
then (PROMPTPRINT (CONCAT "DISPLAYLINK: DRAWLINKFN " FN " NOT FOUND")))
|
||||
(APPLY* (OR (AND DFN FN)
|
||||
'DRAWLINE)
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(ADD1 (GN/RIGHT GNR)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR)))
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(SUB1 (GN/LEFT GNL)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL)))
|
||||
(OR (LISTGET PARAMS 'LINEWIDTH)
|
||||
WIDTH 1)
|
||||
OPERATION STREAM (LISTGET PARAMS 'COLOR)
|
||||
(LISTGET PARAMS 'DASHING)
|
||||
PARAMS])
|
||||
|
||||
(DISPLAYLINK/TB
|
||||
[LAMBDA (TRANS GNT GNB WIDTH OPERATION STREAM PARAMS)
|
||||
[LAMBDA (TRANS GNT GNB WIDTH OPERATION STREAM PARAMS) (* ; "Edited 14-Apr-2026 22:09 by FGH")
|
||||
(* ; "Edited 29-Apr-94 13:59 by sybalsky")
|
||||
|
||||
(* draws a line from the top edge of GNT to the bottom edge of GNR, translated
|
||||
by TRANS)
|
||||
(* draws a line from the top edge of GNT to the bottom edge of GNR, translated by
|
||||
TRANS)
|
||||
|
||||
(APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN)
|
||||
'DRAWLINE)
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(ADD1 (GN/TOP GNT)))
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(SUB1 (GN/BOTTOM GNB)))
|
||||
(OR (LISTGET PARAMS 'LINEWIDTH)
|
||||
WIDTH 1)
|
||||
OPERATION STREAM (LISTGET PARAMS 'COLOR)
|
||||
(LISTGET PARAMS 'DASHING)
|
||||
PARAMS])
|
||||
(LET* [(FN (LISTGET PARAMS 'DRAWLINKFN))
|
||||
(DFN (AND FN (GETD FN]
|
||||
(if (AND FN (NOT DFN))
|
||||
then (PROMPTPRINT (CONCAT "DISPLAYLINK: DRAWLINKFN " FN " NOT FOUND")))
|
||||
(APPLY* (OR (AND DFN FN)
|
||||
'DRAWLINE)
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(ADD1 (GN/TOP GNT)))
|
||||
(IPLUS (fetch XCOORD of TRANS)
|
||||
(fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB)))
|
||||
(IPLUS (fetch YCOORD of TRANS)
|
||||
(SUB1 (GN/BOTTOM GNB)))
|
||||
(OR (LISTGET PARAMS 'LINEWIDTH)
|
||||
WIDTH 1)
|
||||
OPERATION STREAM (LISTGET PARAMS 'COLOR)
|
||||
(LISTGET PARAMS 'DASHING)
|
||||
PARAMS])
|
||||
|
||||
(DISPLAYNODE
|
||||
[LAMBDA (NODE TRANS STREAM G TOSONLY) (* kvl "10-Aug-84 19:08")
|
||||
@@ -2014,7 +2027,7 @@ Copyright (c) 1983-1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
of N])
|
||||
)
|
||||
|
||||
(* Was MODERNIZE loaded before?)
|
||||
(* Was MODERNIZE loaded before?)
|
||||
|
||||
(CL:WHEN (GETD 'MODERNWINDOW.SETUP)
|
||||
(MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE))
|
||||
@@ -3075,7 +3088,7 @@ Copyright (c) 1983-1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(RPAQQ GRAPH/HARDCOPY/FORMAT (MODE PORTRAIT PAGENUMBERS T TRANS NIL))
|
||||
|
||||
(RPAQ? DEFAULT.GRAPH.WINDOWSIZE (LIST (TIMES SCREENWIDTH 0.7)
|
||||
(TIMES SCREENHEIGHT 0.4)))
|
||||
(TIMES SCREENHEIGHT 0.4)))
|
||||
|
||||
(RPAQ? EDITGRAPHMENUCOMMANDS
|
||||
'((Move% Node 'MOVENODE "Moves a single node in the graph." (SUBITEMS (|Move Single Node|
|
||||
@@ -3113,19 +3126,19 @@ Copyright (c) 1983-1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD GRAPHNODE (NODEID NODEPOSITION NODELABELBITMAP NIL NODELABELSHADE NODEWIDTH NODEHEIGHT
|
||||
TONODES FROMNODES NODEFONT NODELABEL NODEBORDER)
|
||||
NODEBORDER _ DEFAULT.GRAPH.NODEBORDER NODELABELSHADE _
|
||||
DEFAULT.GRAPH.NODELABELSHADE NODEFONT _ DEFAULT.GRAPH.NODEFONT)
|
||||
TONODES FROMNODES NODEFONT NODELABEL NODEBORDER)
|
||||
NODEBORDER _ DEFAULT.GRAPH.NODEBORDER NODELABELSHADE _ DEFAULT.GRAPH.NODELABELSHADE
|
||||
NODEFONT _ DEFAULT.GRAPH.NODEFONT)
|
||||
|
||||
(RECORD GRAPH (GRAPHNODES SIDESFLG DIRECTEDFLG GRAPH.MOVENODEFN GRAPH.ADDNODEFN
|
||||
GRAPH.DELETENODEFN GRAPH.ADDLINKFN GRAPH.DELETELINKFN GRAPH.FONTCHANGEFN
|
||||
GRAPH.INVERTBORDERFN GRAPH.INVERTLABELFN GRAPH.CHANGELABELFN . GRAPH.PROPS))
|
||||
(RECORD GRAPH (GRAPHNODES SIDESFLG DIRECTEDFLG GRAPH.MOVENODEFN GRAPH.ADDNODEFN GRAPH.DELETENODEFN
|
||||
GRAPH.ADDLINKFN GRAPH.DELETELINKFN GRAPH.FONTCHANGEFN GRAPH.INVERTBORDERFN
|
||||
GRAPH.INVERTLABELFN GRAPH.CHANGELABELFN . GRAPH.PROPS))
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS HALF MACRO ((X)
|
||||
(LRSH X 1)))
|
||||
(LRSH X 1)))
|
||||
)
|
||||
)
|
||||
|
||||
@@ -3789,61 +3802,59 @@ Copyright (c) 1983-1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(ADDTOVAR IMAGEOBJGETFNS (GRAPHOBJ.GETFN))
|
||||
(PUTPROPS GRAPHER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991
|
||||
1992 1993 1994 2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (7195 111244 (ADD/AND/DISPLAY/LINK 7205 . 7907) (APPLYTOSELECTEDNODE 7909 . 8397) (
|
||||
CALL.MOVENODEFN 8399 . 8748) (CHANGE.NODEFONT.SIZE 8750 . 10062) (DEFAULT.ADDNODEFN 10064 . 10862) (
|
||||
DELETE/AND/DISPLAY/LINK 10864 . 12431) (DISPLAY/NAME 12433 . 12604) (DISPLAYGRAPH 12606 . 14977) (
|
||||
DISPLAYLINK 14979 . 17532) (DISPLAYLINK/BT 17534 . 18556) (DISPLAYLINK/LR 18558 . 19581) (
|
||||
DISPLAYLINK/RL 19583 . 20606) (DISPLAYLINK/TB 20608 . 21631) (DISPLAYNODE 21633 . 21981) (
|
||||
ERASE/GRAPHNODE 21983 . 23090) (DISPLAYNODE 23092 . 23440) (DISPLAYNODELINKS 23442 . 24586) (
|
||||
DRAW/GRAPHNODE/BORDER 24588 . 25507) (DRAWAREABOX 25509 . 26710) (EDITADDLINK 26712 . 27110) (
|
||||
EDITADDNODE 27112 . 29201) (EDITAPPLYTOLINK 29203 . 31282) (EDITCHANGEFONT 31284 . 32456) (
|
||||
EDITCHANGELABEL 32458 . 33999) (EDITDELETELINK 34001 . 34407) (EDITDELETENODE 34409 . 37110) (
|
||||
EDITGRAPH 37112 . 37179) (EDITGRAPH1 37181 . 37939) (EDITGRAPH2 37941 . 39672) (EDITMOVENODE 39674 .
|
||||
41251) (EDITTOGGLEBORDER 41253 . 42549) (EDITTOGGLELABEL 42551 . 43848) (FILL/GRAPHNODE/LABEL 43850 .
|
||||
44678) (FIX/SCALE 44680 . 45236) (FLIPNODE 45238 . 45842) (FONTNAMELIST 45844 . 46063) (FROMLINKS
|
||||
46065 . 46235) (GETNODEFROMID 46237 . 47256) (GN/BOTTOM 47258 . 47534) (GN/LEFT 47536 . 47809) (
|
||||
GN/RIGHT 47811 . 48202) (GN/TOP 48204 . 48628) (GRAPHADDLINK 48630 . 49189) (GRAPHADDNODE 49191 .
|
||||
49980) (GRAPHBUTTONEVENTFN 49982 . 52162) (GRAPHCHANGELABEL 52164 . 52607) (GRAPHDELETELINK 52609 .
|
||||
53917) (GRAPHDELETENODE 53919 . 54451) (GRAPHEDITCOMMANDFN 54453 . 55837) (GRAPHEDITEVENTFN 55839 .
|
||||
56550) (GRAPHER/CENTERPRINTINAREA 56552 . 57316) (GRAPHERPROP 57318 . 57862) (GRAPHNODE/BORDER/WIDTH
|
||||
57864 . 58385) (GRAPHREGION 58387 . 59556) (HARDCOPYGRAPH 59558 . 66940) (INTERSECT/REGIONP/LBWH 66942
|
||||
. 68218) (INVERTED/GRAPHNODE/BORDER 68220 . 68804) (INVERTED/SHADE/FOR/GRAPHER 68806 . 69438) (
|
||||
LAYOUT/POSITION 69440 . 69619) (LINKPARAMETERS 69621 . 70073) (MAX/RIGHT 70075 . 70277) (MAX/TOP 70279
|
||||
. 70477) (MEASUREGRAPHNODE 70479 . 70928) (MEMBTONODES 70930 . 71455) (MIN/BOTTOM 71457 . 71838) (
|
||||
MIN/LEFT 71840 . 72215) (MOVENODE 72217 . 73460) (NODECREATE 73462 . 74242) (NODELST/AS/MENU 74244 .
|
||||
75844) (NODEREGION 75846 . 76306) (PRINTDISPLAYNODE 76308 . 81366) (PROMPTINWINDOW 81368 . 84177) (
|
||||
READ/NODE 84179 . 85293) (REDISPLAYGRAPH 85295 . 85737) (REMOVETONODES 85739 . 86260) (
|
||||
RESET/NODE/BORDER 86262 . 88049) (RESET/NODE/LABELSHADE 88051 . 89566) (SCALE/GRAPH 89568 . 95854) (
|
||||
SCALE/GRAPHNODE/BORDER 95856 . 96551) (SCALE/TONODES 96553 . 97434) (SET/LABEL/SIZE 97436 . 100382) (
|
||||
SET/LAYOUT/POSITION 100384 . 100869) (SHOWGRAPH 100871 . 102670) (SIZE/GRAPH/WINDOW 102672 . 106156) (
|
||||
TOGGLE/DIRECTEDFLG 106158 . 106788) (TOGGLE/SIDESFLG 106790 . 107278) (TOLINKS 107280 . 107446) (
|
||||
TRACKCURSOR 107448 . 108855) (TRACKNODE 108857 . 109493) (TRANSGRAPH 109495 . 111242)) (111485 128102
|
||||
(EDITMOVEREGION 111495 . 115298) (EDITMOVESUBTREE 115300 . 117077) (NOT.TRACKCURSOR 117079 . 120057) (
|
||||
RECURSIVE.COLLECTDESCENDENTS 120059 . 121547) (MOVEDESCENDENTS 121549 . 123611) (COLLECT.CHILD.NODES
|
||||
123613 . 124729) (CREATE.NEW.NODEPOSITION 124731 . 125271) (GETBOXPOSITION.FROMINITIALREGION 125273 .
|
||||
126745) (COLLECTDESCENDENTS 126747 . 128100)) (128166 130455 (NEXTSIZEFONT 128176 . 129366) (
|
||||
DECREASING.FONT.LIST 129368 . 129694) (SCALE.FONT 129696 . 130453)) (130679 169831 (BRH/LAYOUT 130689
|
||||
. 132433) (BRH/LAYOUT/DAUGHTERS 132435 . 133381) (BRH/OFFSET 133383 . 134061) (BRHC/INTERTREE/SPACE
|
||||
134063 . 135381) (BRHC/LAYOUT 135383 . 137239) (BRHC/LAYOUT/DAUGHTERS 137241 . 140195) (
|
||||
BRHC/LAYOUT/TERMINAL 140197 . 140878) (BRHC/OFFSET 140880 . 141776) (BRHL/LAYOUT 141778 . 144002) (
|
||||
BRHL/LAYOUT/DAUGHTERS 144004 . 145762) (BRHL/MOVE/RIGHT 145764 . 146907) (BROWSE/LAYOUT/HORIZ 146909
|
||||
. 147633) (BROWSE/LAYOUT/HORIZ/COMPACTLY 147635 . 150441) (BROWSE/LAYOUT/LATTICE 150443 . 151299) (
|
||||
BRV/OFFSET 151301 . 152164) (EXTEND/TRANSITION/CHAIN 152166 . 153437) (FOREST/BREAK/CYCLES 153439 .
|
||||
154369) (INIT/NODES/FOR/LAYOUT 154371 . 155866) (INTERPRET/MARK/FORMAT 155868 . 157135) (
|
||||
LATTICE/BREAK/CYCLES 157137 . 157841) (LAYOUTFOREST 157843 . 158544) (LAYOUTGRAPH 158546 . 162013) (
|
||||
LAYOUTLATTICE 162015 . 163468) (LAYOUTSEXPR 163470 . 164541) (LAYOUTSEXPR1 164543 . 165245) (
|
||||
MARK/GRAPH/NODE 165247 . 165977) (NEW/INSTANCE/OF/GRAPHNODE 165979 . 167348) (RAISE/TRANSITION/CHAIN
|
||||
167350 . 167751) (REFLECT/GRAPH/DIAGONALLY 167753 . 168482) (REFLECT/GRAPH/HORIZONTALLY 168484 .
|
||||
169010) (REFLECT/GRAPH/VERTICALLY 169012 . 169536) (SWITCH/NODE/HEIGHT/WIDTH 169538 . 169829)) (173177
|
||||
174528 (GRAPHERIMAGEFNS 173187 . 174526)) (174529 176257 (GRAPHERCOPYBUTTONEVENTFN 174539 . 175518) (
|
||||
GRAPHOBJ.FINDGRAPH 175520 . 176255)) (176258 178878 (ALIGNMENTNODE 176268 . 177690) (
|
||||
GRAPHOBJ.CHECKALIGN 177692 . 178876)) (178879 194729 (GRAPHEROBJ 178889 . 180635) (
|
||||
GRAPHOBJ.BUTTONEVENTINFN 180637 . 182064) (GRAPHOBJ.COPYBUTTONEVENTFN 182066 . 182503) (
|
||||
GRAPHOBJ.COPYFN 182505 . 183429) (GRAPHOBJ.DISPLAYFN 183431 . 186246) (GRAPHOBJ.GETALIGN 186248 .
|
||||
186987) (GRAPHOBJ.GETFN 186989 . 188494) (GRAPHOBJ.IMAGEBOXFN 188496 . 192512) (GRAPHOBJ.PUTALIGN
|
||||
192514 . 193344) (GRAPHOBJ.PUTFN 193346 . 194727)) (194730 213882 (COPYGRAPH 194740 . 196288) (
|
||||
DUMPGRAPH 196290 . 206546) (READGRAPH 206548 . 213880)))))
|
||||
(FILEMAP (NIL (7149 112538 (ADD/AND/DISPLAY/LINK 7159 . 7861) (APPLYTOSELECTEDNODE 7863 . 8351) (
|
||||
CALL.MOVENODEFN 8353 . 8702) (CHANGE.NODEFONT.SIZE 8704 . 10016) (DEFAULT.ADDNODEFN 10018 . 10816) (
|
||||
DELETE/AND/DISPLAY/LINK 10818 . 12385) (DISPLAY/NAME 12387 . 12558) (DISPLAYGRAPH 12560 . 14931) (
|
||||
DISPLAYLINK 14933 . 17486) (DISPLAYLINK/BT 17488 . 18845) (DISPLAYLINK/LR 18847 . 20205) (
|
||||
DISPLAYLINK/RL 20207 . 21565) (DISPLAYLINK/TB 21567 . 22925) (DISPLAYNODE 22927 . 23275) (
|
||||
ERASE/GRAPHNODE 23277 . 24384) (DISPLAYNODE 24386 . 24734) (DISPLAYNODELINKS 24736 . 25880) (
|
||||
DRAW/GRAPHNODE/BORDER 25882 . 26801) (DRAWAREABOX 26803 . 28004) (EDITADDLINK 28006 . 28404) (
|
||||
EDITADDNODE 28406 . 30495) (EDITAPPLYTOLINK 30497 . 32576) (EDITCHANGEFONT 32578 . 33750) (
|
||||
EDITCHANGELABEL 33752 . 35293) (EDITDELETELINK 35295 . 35701) (EDITDELETENODE 35703 . 38404) (
|
||||
EDITGRAPH 38406 . 38473) (EDITGRAPH1 38475 . 39233) (EDITGRAPH2 39235 . 40966) (EDITMOVENODE 40968 .
|
||||
42545) (EDITTOGGLEBORDER 42547 . 43843) (EDITTOGGLELABEL 43845 . 45142) (FILL/GRAPHNODE/LABEL 45144 .
|
||||
45972) (FIX/SCALE 45974 . 46530) (FLIPNODE 46532 . 47136) (FONTNAMELIST 47138 . 47357) (FROMLINKS
|
||||
47359 . 47529) (GETNODEFROMID 47531 . 48550) (GN/BOTTOM 48552 . 48828) (GN/LEFT 48830 . 49103) (
|
||||
GN/RIGHT 49105 . 49496) (GN/TOP 49498 . 49922) (GRAPHADDLINK 49924 . 50483) (GRAPHADDNODE 50485 .
|
||||
51274) (GRAPHBUTTONEVENTFN 51276 . 53456) (GRAPHCHANGELABEL 53458 . 53901) (GRAPHDELETELINK 53903 .
|
||||
55211) (GRAPHDELETENODE 55213 . 55745) (GRAPHEDITCOMMANDFN 55747 . 57131) (GRAPHEDITEVENTFN 57133 .
|
||||
57844) (GRAPHER/CENTERPRINTINAREA 57846 . 58610) (GRAPHERPROP 58612 . 59156) (GRAPHNODE/BORDER/WIDTH
|
||||
59158 . 59679) (GRAPHREGION 59681 . 60850) (HARDCOPYGRAPH 60852 . 68234) (INTERSECT/REGIONP/LBWH 68236
|
||||
. 69512) (INVERTED/GRAPHNODE/BORDER 69514 . 70098) (INVERTED/SHADE/FOR/GRAPHER 70100 . 70732) (
|
||||
LAYOUT/POSITION 70734 . 70913) (LINKPARAMETERS 70915 . 71367) (MAX/RIGHT 71369 . 71571) (MAX/TOP 71573
|
||||
. 71771) (MEASUREGRAPHNODE 71773 . 72222) (MEMBTONODES 72224 . 72749) (MIN/BOTTOM 72751 . 73132) (
|
||||
MIN/LEFT 73134 . 73509) (MOVENODE 73511 . 74754) (NODECREATE 74756 . 75536) (NODELST/AS/MENU 75538 .
|
||||
77138) (NODEREGION 77140 . 77600) (PRINTDISPLAYNODE 77602 . 82660) (PROMPTINWINDOW 82662 . 85471) (
|
||||
READ/NODE 85473 . 86587) (REDISPLAYGRAPH 86589 . 87031) (REMOVETONODES 87033 . 87554) (
|
||||
RESET/NODE/BORDER 87556 . 89343) (RESET/NODE/LABELSHADE 89345 . 90860) (SCALE/GRAPH 90862 . 97148) (
|
||||
SCALE/GRAPHNODE/BORDER 97150 . 97845) (SCALE/TONODES 97847 . 98728) (SET/LABEL/SIZE 98730 . 101676) (
|
||||
SET/LAYOUT/POSITION 101678 . 102163) (SHOWGRAPH 102165 . 103964) (SIZE/GRAPH/WINDOW 103966 . 107450) (
|
||||
TOGGLE/DIRECTEDFLG 107452 . 108082) (TOGGLE/SIDESFLG 108084 . 108572) (TOLINKS 108574 . 108740) (
|
||||
TRACKCURSOR 108742 . 110149) (TRACKNODE 110151 . 110787) (TRANSGRAPH 110789 . 112536)) (112779 129396
|
||||
(EDITMOVEREGION 112789 . 116592) (EDITMOVESUBTREE 116594 . 118371) (NOT.TRACKCURSOR 118373 . 121351) (
|
||||
RECURSIVE.COLLECTDESCENDENTS 121353 . 122841) (MOVEDESCENDENTS 122843 . 124905) (COLLECT.CHILD.NODES
|
||||
124907 . 126023) (CREATE.NEW.NODEPOSITION 126025 . 126565) (GETBOXPOSITION.FROMINITIALREGION 126567 .
|
||||
128039) (COLLECTDESCENDENTS 128041 . 129394)) (129460 131749 (NEXTSIZEFONT 129470 . 130660) (
|
||||
DECREASING.FONT.LIST 130662 . 130988) (SCALE.FONT 130990 . 131747)) (131973 171125 (BRH/LAYOUT 131983
|
||||
. 133727) (BRH/LAYOUT/DAUGHTERS 133729 . 134675) (BRH/OFFSET 134677 . 135355) (BRHC/INTERTREE/SPACE
|
||||
135357 . 136675) (BRHC/LAYOUT 136677 . 138533) (BRHC/LAYOUT/DAUGHTERS 138535 . 141489) (
|
||||
BRHC/LAYOUT/TERMINAL 141491 . 142172) (BRHC/OFFSET 142174 . 143070) (BRHL/LAYOUT 143072 . 145296) (
|
||||
BRHL/LAYOUT/DAUGHTERS 145298 . 147056) (BRHL/MOVE/RIGHT 147058 . 148201) (BROWSE/LAYOUT/HORIZ 148203
|
||||
. 148927) (BROWSE/LAYOUT/HORIZ/COMPACTLY 148929 . 151735) (BROWSE/LAYOUT/LATTICE 151737 . 152593) (
|
||||
BRV/OFFSET 152595 . 153458) (EXTEND/TRANSITION/CHAIN 153460 . 154731) (FOREST/BREAK/CYCLES 154733 .
|
||||
155663) (INIT/NODES/FOR/LAYOUT 155665 . 157160) (INTERPRET/MARK/FORMAT 157162 . 158429) (
|
||||
LATTICE/BREAK/CYCLES 158431 . 159135) (LAYOUTFOREST 159137 . 159838) (LAYOUTGRAPH 159840 . 163307) (
|
||||
LAYOUTLATTICE 163309 . 164762) (LAYOUTSEXPR 164764 . 165835) (LAYOUTSEXPR1 165837 . 166539) (
|
||||
MARK/GRAPH/NODE 166541 . 167271) (NEW/INSTANCE/OF/GRAPHNODE 167273 . 168642) (RAISE/TRANSITION/CHAIN
|
||||
168644 . 169045) (REFLECT/GRAPH/DIAGONALLY 169047 . 169776) (REFLECT/GRAPH/HORIZONTALLY 169778 .
|
||||
170304) (REFLECT/GRAPH/VERTICALLY 170306 . 170830) (SWITCH/NODE/HEIGHT/WIDTH 170832 . 171123)) (174438
|
||||
175789 (GRAPHERIMAGEFNS 174448 . 175787)) (175790 177518 (GRAPHERCOPYBUTTONEVENTFN 175800 . 176779) (
|
||||
GRAPHOBJ.FINDGRAPH 176781 . 177516)) (177519 180139 (ALIGNMENTNODE 177529 . 178951) (
|
||||
GRAPHOBJ.CHECKALIGN 178953 . 180137)) (180140 195990 (GRAPHEROBJ 180150 . 181896) (
|
||||
GRAPHOBJ.BUTTONEVENTINFN 181898 . 183325) (GRAPHOBJ.COPYBUTTONEVENTFN 183327 . 183764) (
|
||||
GRAPHOBJ.COPYFN 183766 . 184690) (GRAPHOBJ.DISPLAYFN 184692 . 187507) (GRAPHOBJ.GETALIGN 187509 .
|
||||
188248) (GRAPHOBJ.GETFN 188250 . 189755) (GRAPHOBJ.IMAGEBOXFN 189757 . 193773) (GRAPHOBJ.PUTALIGN
|
||||
193775 . 194605) (GRAPHOBJ.PUTFN 194607 . 195988)) (195991 215143 (COPYGRAPH 196001 . 197549) (
|
||||
DUMPGRAPH 197551 . 207807) (READGRAPH 207809 . 215141)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "31-Mar-2026 00:14:19" {WMEDLEY}<library>UNIXUTILS.;58 21269
|
||||
(FILECREATED "27-Apr-2026 11:10:07" {DSK}<home>frank>il>medley>library>UNIXUTILS.;7 21772
|
||||
|
||||
:EDIT-BY rmk
|
||||
:EDIT-BY "FGH"
|
||||
|
||||
:CHANGES-TO (FNS UNIX-FILE-NAME)
|
||||
:CHANGES-TO (FNS ShellOpen SLASHIT)
|
||||
|
||||
:PREVIOUS-DATE "29-Mar-2026 00:26:43" {WMEDLEY}<library>UNIXUTILS.;57)
|
||||
:PREVIOUS-DATE "31-Mar-2026 00:14:19" {DSK}<home>frank>il>medley>library>UNIXUTILS.;3)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNIXUTILSCOMS)
|
||||
@@ -148,7 +148,8 @@
|
||||
"true"])
|
||||
|
||||
(ShellOpen
|
||||
[LAMBDA (FilenameOrURL) (* ; "Edited 28-Dec-2025 18:26 by rmk")
|
||||
[LAMBDA (FilenameOrURL) (* ; "Edited 27-Apr-2026 11:08 by FGH")
|
||||
(* ; "Edited 28-Dec-2025 18:26 by rmk")
|
||||
(* ; "Edited 10-Sep-2025 15:29 by rmk")
|
||||
(* ; "Edited 4-May-2025 11:14 by rmk")
|
||||
|
||||
@@ -210,7 +211,8 @@
|
||||
'NAME NEWNAME 'EXTENSION EXTENSION))
|
||||
(TARGETFILE.UNIX (SLASHIT (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY
|
||||
TMPDIR 'NAME NEWNAME 'EXTENSION
|
||||
EXTENSION)))
|
||||
EXTENSION)
|
||||
NIL NIL NIL T))
|
||||
(UNIXFILE NIL))
|
||||
(DECLARE (SPECVARS UNIXFILE))
|
||||
(if (OR VERSION.SPECIFIED (NOT UNVERSIONED.EXISTS))
|
||||
@@ -245,7 +247,8 @@
|
||||
0))) DO (BLOCK) FINALLY (RETURN CODE])
|
||||
|
||||
(SLASHIT
|
||||
[LAMBDA (X LCASEDIRS NOHOST KEEPDOT) (* ; "Edited 17-Jan-2026 23:15 by rmk")
|
||||
[LAMBDA (X LCASEDIRS NOHOST KEEPDOT NO.QUOTE.SPACE) (* ; "Edited 27-Apr-2026 11:00 by FGH")
|
||||
(* ; "Edited 17-Jan-2026 23:15 by rmk")
|
||||
(* ; "Edited 4-Nov-2025 10:10 by rmk")
|
||||
(* ; "Edited 22-Oct-2025 13:05 by rmk")
|
||||
(* ; "Edited 25-Sep-2025 09:57 by rmk")
|
||||
@@ -258,7 +261,10 @@
|
||||
(* ;; "This is a first approximation to a utility that converts a filename X on a host whose files physically reside in the local Unix file system into the strings that shell commands can use to reference that file. For now, this just involves replacing directory brackets with /, removing the host, perhaps lower-casing the directory, and perhaps removing a final dot. It probably should be extended to deal with version number translation, for now it just keeps the ; version. ")
|
||||
|
||||
(LET [LASTDIRPOS SLASHED (DIRPOS (ADD1 (OR (STRPOS "}" X)
|
||||
0]
|
||||
0)))
|
||||
(REPLACE.SPACE (if NO.QUOTE.SPACE
|
||||
then (CONS (CHARCODE SPACE))
|
||||
else (CHARCODE (\ SPACE]
|
||||
[SETQ SLASHED (CONCATCODES (for I C from DIRPOS while (SETQ C (NTHCHARCODE X I))
|
||||
join (SELCHARQ C
|
||||
((< >)
|
||||
@@ -266,7 +272,7 @@
|
||||
(CONS (CHARCODE /)))
|
||||
(/ (SETQ LASTDIRPOS I)
|
||||
(CONS C))
|
||||
(SPACE (APPEND (CHARCODE (\ SPACE))))
|
||||
(SPACE (APPEND REPLACE.SPACE))
|
||||
(CONS C]
|
||||
(CL:WHEN (AND LCASEDIRS LASTDIRPOS)
|
||||
(SETQ LASTDIRPOS (ADD1 (IDIFFERENCE LASTDIRPOS DIRPOS)))
|
||||
@@ -367,8 +373,8 @@
|
||||
|
||||
(PUTPROPS UNIXUTILS FILETYPE CL:COMPILE-FILE)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1170 1543 (ShellCommand 1170 . 1543)) (1545 1942 (ShellWhich 1545 . 1942)) (2052 21191
|
||||
(ShellBrowser 2062 . 3834) (ShellBrowse 3836 . 4521) (ShellOpener 4523 . 6211) (ShellOpen 6213 . 11982
|
||||
) (PROCESS-COMMAND 11984 . 12597) (SLASHIT 12599 . 15623) (UNIX-FILE-NAME 15625 . 19510) (
|
||||
UNIX-TMP-FILE-NAME 19512 . 21189)))))
|
||||
(FILEMAP (NIL (1207 1580 (ShellCommand 1207 . 1580)) (1582 1979 (ShellWhich 1582 . 1979)) (2089 21694
|
||||
(ShellBrowser 2099 . 3871) (ShellBrowse 3873 . 4558) (ShellOpener 4560 . 6248) (ShellOpen 6250 . 12197
|
||||
) (PROCESS-COMMAND 12199 . 12812) (SLASHIT 12814 . 16126) (UNIX-FILE-NAME 16128 . 20013) (
|
||||
UNIX-TMP-FILE-NAME 20015 . 21692)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
@@ -1,17 +1,18 @@
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" ( USE "XCL" "LISP") ( EXPORT "READ-BDF" "BUILD-COMPOSITE"
|
||||
"WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE") ( IMPORT-FROM "IL" "BITBLT" "BITMAPBIT" "BITMAPCREATE"
|
||||
"BITMAPHEIGHT" "BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" "BOLD" "COMPRESSED" "CHARSETINFO" "DISPLAY"
|
||||
"FONTDESCRIPTOR" "FONTP" "FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH" "MCCS" "MEDIUM" "REGULAR" "TCONC"
|
||||
"UTOMCODE?" "MEDLEYFONT.FILENAME" "MEDLEYFONT.WRITE.FONT")) READTABLE "XCL" BASE 10)
|
||||
"BITMAPHEIGHT" "BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" "BOLD" "COMPRESSED" "CHARSETINFO" "CHARSETPROP"
|
||||
"DISPLAY" "FONTDESCRIPTOR" "FONTP" "FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH" "MCCS" "MEDIUM"
|
||||
"REGULAR" "TCONC" "UTOMCODE?" "MEDLEYFONT.FILENAME" "MEDLEYFONT.WRITE.FONT")) READTABLE "XCL" BASE
|
||||
10)
|
||||
|
||||
(IL:FILECREATED "16-Mar-2026 16:37:31" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;22| 58094
|
||||
(IL:FILECREATED " 8-Dec-2025 12:13:40" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;9| 51309
|
||||
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (IL:FUNCTIONS READ-GLYPH READ-BDF BDF-TO-FONTDESCRIPTOR GLYPHS-BY-CHARSET
|
||||
WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE BDF-TO-CHARSETINFO)
|
||||
:CHANGES-TO (IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR)
|
||||
(FILE-ENVIRONMENTS "READ-BDF")
|
||||
|
||||
:PREVIOUS-DATE "23-Feb-2026 20:11:48" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;21|
|
||||
:PREVIOUS-DATE " 8-Dec-2025 12:12:47" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;8|
|
||||
)
|
||||
|
||||
|
||||
@@ -19,7 +20,7 @@
|
||||
|
||||
(IL:RPAQQ IL:READ-BDFCOMS
|
||||
((IL:STRUCTURES BDF-FONT GLYPH XLFD)
|
||||
(IL:VARIABLES GLYPH-PROCESSING-HOOK MAXCHARSET MAXTHINCHAR NOMAPPINGCHARSET)
|
||||
(IL:VARIABLES MAXCHARSET MAXTHINCHAR NOMAPPINGCHARSET)
|
||||
(IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR BUILD-COMPOSITE CHAR-PRESENT-BIT
|
||||
COUNT-MCHARS GLYPHS-BY-CHARSET PACKFILENAME.STRING READ-BDF
|
||||
READ-DELIMITED-LIST-FROM-STRING READ-GLYPH WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE
|
||||
@@ -70,17 +71,13 @@
|
||||
(CHARSET昱EGISTRY NIL :TYPE STRING)
|
||||
(CHARSET挂NCODING NIL :TYPE STRING))
|
||||
|
||||
(DEFVAR GLYPH-PROCESSING-HOOK NIL)
|
||||
|
||||
(DEFCONSTANT MAXCHARSET 255)
|
||||
|
||||
(DEFCONSTANT MAXTHINCHAR 255)
|
||||
|
||||
(DEFCONSTANT NOMAPPINGCHARSET (1+ MAXCHARSET))
|
||||
|
||||
(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUGWIDTH &KEY AS-UNICODE)
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 16:35 by mth")
|
||||
(IL:* IL:\; "Edited 8-Dec-2025 12:13 by mth")
|
||||
(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUGWIDTH) (IL:* IL:\; "Edited 8-Dec-2025 12:13 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 00:12 by mth")
|
||||
(IL:* IL:\; "Edited 28-Nov-2025 16:37 by mth")
|
||||
(IL:* IL:\; "Edited 26-Nov-2025 21:18 by mth")
|
||||
@@ -110,7 +107,7 @@
|
||||
(IL:* IL:|;;| "If passed a BDF-FONT, look only at glyphs in the mapped charsets")
|
||||
|
||||
(DESTRUCTURING-SETQ (GBCS SW)
|
||||
(GLYPHS-BY-CHARSET FONT :AS-UNICODE AS-UNICODE)))
|
||||
(GLYPHS-BY-CHARSET FONT)))
|
||||
(T (ERROR "Invalid FONT: ~S" FONT)))
|
||||
(UNLESS (AND (INTEGERP SLUGWIDTH)
|
||||
(PLUSP SLUGWIDTH))
|
||||
@@ -129,9 +126,7 @@
|
||||
(IMAGEWIDTHS (IL:\\CREATECSINFOELEMENT))
|
||||
(DLEFT 0)
|
||||
GLYPHS-LIMITS BMAP OFFSETS HEIGHT WIDTHS)
|
||||
(IL:CHARSETPROP CSINFO 'IL:CSCHARENCODING (IF AS-UNICODE
|
||||
'IL:UNICODE
|
||||
'MCCS))
|
||||
(CHARSETPROP CSINFO 'IL:CSCHARENCODING 'MCCS)
|
||||
(LOOP :FOR XGL :IN CSGLYPHS :DO (LET* ((MCODE (CAR XGL))
|
||||
(GL (CDR XGL))
|
||||
(GWIDTH (GLYPH-WIDTH GL))
|
||||
@@ -206,8 +201,7 @@
|
||||
'IL:REPLACE)
|
||||
CSINFO))))
|
||||
|
||||
(DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE &KEY AS-UNICODE)
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 16:16 by mth")
|
||||
(DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE)
|
||||
(IL:* IL:\; "Edited 8-Dec-2025 12:11 by mth")
|
||||
(IL:* IL:\; "Edited 2-Dec-2025 16:10 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 15:59 by mth")
|
||||
@@ -226,8 +220,7 @@
|
||||
(OR SIZE (FONTPROP FAMILY 'IL:SIZE))
|
||||
(OR FACE (FONTPROP FAMILY 'IL:FACE))
|
||||
(OR ROTATION (FONTPROP FAMILY 'IL:ROTATION))
|
||||
(OR DEVICE (FONTPROP FAMILY 'IL:DEVICE))
|
||||
:AS-UNICODE AS-UNICODE)))
|
||||
(OR DEVICE (FONTPROP FAMILY 'IL:DEVICE)))))
|
||||
(WHEN (CONSP FAMILY) (IL:* IL:\;
|
||||
"Because (LISTP NIL) == T !!!")
|
||||
|
||||
@@ -247,8 +240,7 @@
|
||||
0)
|
||||
(OR DEVICE (IL:|fetch| (IL:FONTSPEC IL:FSDEVICE)
|
||||
IL:|of| FAMILY)
|
||||
'DISPLAY)
|
||||
:AS-UNICODE AS-UNICODE)))
|
||||
'DISPLAY))))
|
||||
(LET ((XLFD (BF-XLFD BDFONT))
|
||||
FONTDESC GBCSL CHARSETS SLUGWIDTH)
|
||||
(SETQ FAMILY (IL:\\FONTSYMBOL (OR FAMILY (XLFD-FAMILY XLFD))))
|
||||
@@ -288,7 +280,7 @@
|
||||
'IL:MRR)
|
||||
NIL DEVICE))
|
||||
(DESTRUCTURING-SETQ (GBCSL SLUGWIDTH)
|
||||
(GLYPHS-BY-CHARSET BDFONT :AS-UNICODE AS-UNICODE))
|
||||
(GLYPHS-BY-CHARSET BDFONT))
|
||||
(UNLESS SLUGWIDTH
|
||||
|
||||
(IL:* IL:|;;|
|
||||
@@ -308,21 +300,16 @@
|
||||
IL:ROTATION IL:_ ROTATION
|
||||
IL:FONTDEVICESPEC IL:_ (LIST FAMILY SIZE FACE ROTATION DEVICE)
|
||||
IL:FONTSLUGWIDTH IL:_ SLUGWIDTH
|
||||
IL:FONTCHARENCODING IL:_ (IF AS-UNICODE
|
||||
'IL:UNICODE
|
||||
'MCCS)))
|
||||
IL:FONTCHARENCODING IL:_ 'MCCS))
|
||||
(SETQ CHARSETS (LOOP :FOR CS :IN GBCSL :WITH CSET :WITH CSINFO :NCONC
|
||||
(WHEN (<= 0 (SETQ CSET (FIRST CS))
|
||||
MAXCHARSET)
|
||||
(SETQ CSINFO (BDF-TO-CHARSETINFO GBCSL CSET (1+ SLUGWIDTH)
|
||||
:AS-UNICODE AS-UNICODE))
|
||||
(SETQ CSINFO (BDF-TO-CHARSETINFO GBCSL CSET (1+ SLUGWIDTH)))
|
||||
(IL:\\INSTALLCHARSETINFO FONTDESC CSINFO CSET)
|
||||
(LIST CSET)))))
|
||||
(LIST FONTDESC CHARSETS))))
|
||||
|
||||
(DEFUN BUILD-COMPOSITE (FONTS &KEY VERBOSE (BLOCKING T))
|
||||
(IL:* IL:\; "Edited 19-Feb-2026 21:45 by mth")
|
||||
(IL:* IL:\; "Edited 1-Dec-2025 23:07 by mth")
|
||||
(DEFUN BUILD-COMPOSITE (FONTS &KEY VERBOSE) (IL:* IL:\; "Edited 1-Dec-2025 23:07 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 12:32 by mth")
|
||||
(IL:* IL:\; "Edited 26-Nov-2025 21:23 by mth")
|
||||
(IL:* IL:\; "Edited 18-Nov-2025 21:22 by mth")
|
||||
@@ -340,61 +327,53 @@
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT* "~&Loading initial font file: ~A~%" (NAMESTRING BASE-FONT)
|
||||
))
|
||||
(SETQ BASE-FONT (READ-BDF BASE-FONT :MCCS-ONLY T :VERBOSE VERBOSE))
|
||||
(WHEN BLOCKING (IL:BLOCK)))
|
||||
(SETQ BASE-FONT (READ-BDF BASE-FONT :MCCS-ONLY T :VERBOSE VERBOSE)))
|
||||
((NOT (BDF-FONT-P BASE-FONT))
|
||||
(ERROR "Initial font (~S) is not a BDF-FONT, nor string, nor pathname." BASE-FONT)))
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT* "~&Initial font contains ~D MCCS characters.~%"
|
||||
(SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))))
|
||||
(SETQ MCHAR-PRESENT (BF-MCHAR-PRESENT BASE-FONT))
|
||||
(LOOP :FOR FILL-FONT :IN FILL-FROM :WITH PREV-CC :WITH FF-NAME :WHEN FILL-FONT :DO
|
||||
(FLET ((MERGE-GLYPH (GL &AUX V)
|
||||
(SETQ V (GLYPH-ENCODING GL))
|
||||
(WHEN (AND (LISTP V)
|
||||
(EQ (FIRST V)
|
||||
-1))
|
||||
(SETQ V (OR (SECOND V)
|
||||
-1)))
|
||||
(LOOP :FOR FILL-FONT :IN FILL-FROM :WITH PREV-CC :WHEN FILL-FONT :DO
|
||||
(COND
|
||||
((OR (STRINGP FILL-FONT)
|
||||
(PATHNAMEP FILL-FONT))
|
||||
(UNLESS (IL:INFILEP FILL-FONT)
|
||||
(ERROR "Subsequent font ~S doesn't exist or is unreadable." (NAMESTRING
|
||||
FILL-FONT)))
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT* "~&Loading subsequent font file: ~A~%" (NAMESTRING
|
||||
FILL-FONT)))
|
||||
(SETQ FILL-FONT (READ-BDF FILL-FONT :MCCS-ONLY T :VERBOSE VERBOSE)))
|
||||
((NOT (BDF-FONT-P FILL-FONT))
|
||||
(ERROR "Subsequent font (~S) is not a BDF-FONT, nor string, nor pathname."
|
||||
FILL-FONT)))
|
||||
(SETQ PREV-CC CHAR-COUNT)
|
||||
(LOOP :FOR GL :IN (BF-GLYPHS FILL-FONT)
|
||||
:WITH V :DO (SETQ V (GLYPH-ENCODING GL))
|
||||
(WHEN (AND (LISTP V)
|
||||
(EQ (FIRST V)
|
||||
-1))
|
||||
(SETQ V (OR (SECOND V)
|
||||
-1)))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
(IL:* IL:|;;|
|
||||
"Need to change this use of UTOMCODE? based on the CHARSET昱EGISTRY of the XLFD of FILL-FONT")
|
||||
|
||||
(WHEN (AND (UTOMCODE? V)
|
||||
(ZEROP (CHAR-PRESENT-BIT MCHAR-PRESENT V)))
|
||||
(CHAR-PRESENT-BIT MCHAR-PRESENT V 1)
|
||||
(WHEN (AND (UTOMCODE? V)
|
||||
(ZEROP (CHAR-PRESENT-BIT MCHAR-PRESENT V)))
|
||||
(CHAR-PRESENT-BIT MCHAR-PRESENT V 1)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
(IL:* IL:|;;|
|
||||
"What other bookkeping of BASE-FONT needs to be done when adding a glyph? Any?")
|
||||
|
||||
(PUSH GL (BF-GLYPHS BASE-FONT)))
|
||||
NIL))
|
||||
(COND
|
||||
((OR (STRINGP FILL-FONT)
|
||||
(PATHNAMEP FILL-FONT))
|
||||
(SETQ FF-NAME (NAMESTRING FILL-FONT))
|
||||
(UNLESS (IL:INFILEP FILL-FONT)
|
||||
(ERROR "Subsequent font ~S doesn't exist or is unreadable." FF-NAME))
|
||||
(WHEN VERBOSE (FORMAT *STANDARD-OUTPUT*
|
||||
"~&Loading subsequent font file: ~A~%" FF-NAME))
|
||||
(LET ((GLYPH-PROCESSING-HOOK #'MERGE-GLYPH))
|
||||
(READ-BDF FILL-FONT :MCCS-ONLY T :VERBOSE VERBOSE)
|
||||
(SETQ FILL-FONT NIL))
|
||||
(WHEN BLOCKING (IL:BLOCK)))
|
||||
((NOT (BDF-FONT-P FILL-FONT))
|
||||
(ERROR "Subsequent font (~S) is not a BDF-FONT, nor string, nor pathname."
|
||||
FF-NAME)))
|
||||
(SETQ PREV-CC CHAR-COUNT)
|
||||
(WHEN FILL-FONT
|
||||
(LOOP :FOR GL :IN (BF-GLYPHS FILL-FONT)
|
||||
:DO
|
||||
(MERGE-GLYPH GL)))
|
||||
(SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT*
|
||||
"~&Font ~A supplied ~D additional MCCS characters.~%" FF-NAME
|
||||
(- (SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))
|
||||
PREV-CC)))))
|
||||
(PUSH GL (BF-GLYPHS BASE-FONT))))
|
||||
(SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT* "~&Font ~A supplied ~D additional MCCS characters.~%"
|
||||
(NAMESTRING FILL-FONT)
|
||||
(- (SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))
|
||||
PREV-CC))))
|
||||
BASE-FONT))
|
||||
|
||||
(DEFUN CHAR-PRESENT-BIT (BM MCODE &OPTIONAL (NEWBIT -1 SBIT)
|
||||
@@ -422,8 +401,7 @@
|
||||
(LET ((MCPBM (BF-MCHAR-PRESENT BDFONT)))
|
||||
(LOOP :FOR MC :FROM 0 :TO 65535 :COUNT (PLUSP (CHAR-PRESENT-BIT MCPBM MC))))))
|
||||
|
||||
(DEFUN GLYPHS-BY-CHARSET (FONT &KEY AS-UNICODE) (IL:* IL:\; "Edited 16-Mar-2026 16:06 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 17:36 by mth")
|
||||
(DEFUN GLYPHS-BY-CHARSET (FONT) (IL:* IL:\; "Edited 30-Nov-2025 17:36 by mth")
|
||||
(IL:* IL:\; "Edited 28-Nov-2025 17:24 by mth")
|
||||
(IL:* IL:\; "Edited 26-Nov-2025 20:50 by mth")
|
||||
(IL:* IL:\; "Edited 20-Nov-2025 12:01 by mth")
|
||||
@@ -493,9 +471,7 @@
|
||||
X))
|
||||
Y))))
|
||||
|
||||
(DEFUN READ-BDF (PATH &KEY VERBOSE MCCS-ONLY AS-UNICODE (EXTERNAL-FORMAT :ISO8859/1))
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 16:11 by mth")
|
||||
(IL:* IL:\; "Edited 19-Feb-2026 21:42 by mth")
|
||||
(DEFUN READ-BDF (PATH &KEY VERBOSE MCCS-ONLY (EXTERNAL-FORMAT :ISO8859/1))
|
||||
(IL:* IL:\; "Edited 1-Dec-2025 22:40 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 11:59 by mth")
|
||||
(IL:* IL:\; "Edited 28-Nov-2025 17:39 by mth")
|
||||
@@ -610,43 +586,16 @@
|
||||
(PLUSP NGLYPHS))
|
||||
(ERROR "Invalid BDF file - CHARS count (~A) is invalid or missing."
|
||||
NGLYPHS))
|
||||
(LOOP :REPEAT NGLYPHS :WITH ENC :WITH MC :DO
|
||||
(SETQ GL (READ-GLYPH FILE-STREAM FONT :MCCS-ONLY MCCS-ONLY :AS-UNICODE
|
||||
AS-UNICODE))
|
||||
(LOOP :REPEAT NGLYPHS :WITH ENC :WITH MC :DO (SETQ GL (READ-GLYPH
|
||||
FILE-STREAM
|
||||
FONT))
|
||||
(SETQ ENC (GLYPH-ENCODING GL))
|
||||
(WHEN (AND (LISTP ENC)
|
||||
(EQL (FIRST ENC)
|
||||
-1))
|
||||
(EQ (FIRST ENC)
|
||||
-1))
|
||||
(SETQ ENC (OR (SECOND ENC)
|
||||
-1)))
|
||||
(COND
|
||||
(AS-UNICODE
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"IS THIS TRUE IF REMAINING IN UNICODE ENCODING?")
|
||||
|
||||
(IL:* IL:|;;| "This glyph must have either a non-zero-width \"image\" or a non-zero-width \"escapement\", otherwise it cannot be mapped, no matter the UTOMCODE? value.")
|
||||
|
||||
(IL:* IL:|;;| "For now, assuming NOT TRUE")
|
||||
|
||||
(WHEN (AND GLYPH-PROCESSING-HOOK (FUNCTIONP
|
||||
GLYPH-PROCESSING-HOOK
|
||||
))
|
||||
(SETQ GL (FUNCALL GLYPH-PROCESSING-HOOK GL)))
|
||||
(WHEN GL
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Everything is mappable if in 0000-FFFF range")
|
||||
|
||||
(IF (<= 0 ENC 65535)
|
||||
(PROGN (SETF (GLYPH-MCODE GL)
|
||||
ENC)
|
||||
(TCONC MAPPED-GLYPHS GL))
|
||||
(TCONC UNMAPPED-GLYPHS GL)))
|
||||
|
||||
(IL:* IL:|;;| "Don't bother with MCHAR-PRESENT bits")
|
||||
|
||||
)
|
||||
((AND (OR (PLUSP (GLYPH-BBW GL))
|
||||
(PLUSP (FIRST (GLYPH-DWIDTH GL))))
|
||||
(SETQ MC (UTOMCODE? ENC)))
|
||||
@@ -666,200 +615,143 @@
|
||||
|
||||
(IL:* IL:|;;| "It ought to be safe to share the bitmap")
|
||||
|
||||
(WHEN (AND GLYPH-PROCESSING-HOOK (FUNCTIONP
|
||||
GLYPH-PROCESSING-HOOK
|
||||
))
|
||||
(SETQ CGL (FUNCALL GLYPH-PROCESSING-HOOK CGL)))
|
||||
(WHEN CGL (TCONC MAPPED-GLYPHS CGL))
|
||||
(TCONC MAPPED-GLYPHS CGL)
|
||||
(CHAR-PRESENT-BIT MCHAR-PRESENT CC 1)))
|
||||
((NOT MCCS-ONLY)
|
||||
(WHEN (AND GLYPH-PROCESSING-HOOK (FUNCTIONP GLYPH-PROCESSING-HOOK)
|
||||
)
|
||||
(SETQ GL (FUNCALL GLYPH-PROCESSING-HOOK GL)))
|
||||
(WHEN GL (TCONC UNMAPPED-GLYPHS GL)))))
|
||||
(T (TCONC UNMAPPED-GLYPHS GL))))
|
||||
(SETF (BF-GLYPHS FONT)
|
||||
(CAR MAPPED-GLYPHS))
|
||||
(SETF (BF-UNMAPPED故LYPHS FONT)
|
||||
(CAR UNMAPPED-GLYPHS)))
|
||||
(ENDFONT (SETQ FONT-COMPLETE T)))))))))
|
||||
(WHEN VERBOSE
|
||||
(ENDFONT (SETQ FONT-COMPLETE T))))))))
|
||||
(WHEN VERBOSE
|
||||
|
||||
(IL:* IL:|;;| "The SIZE reported needs clarification:")
|
||||
(IL:* IL:|;;| "The SIZE reported needs clarification:")
|
||||
|
||||
(FORMAT *STANDARD-OUTPUT* "Name: ~A~%Family: ~A~%Sizes: Font: ~A Pixel: ~A Point: ~A (decipoints)~%Weight: ~A~%Slant: ~A~%Expansion: ~A~%Glyphs: ~D~%Unmapped glyphs: ~D~%"
|
||||
(BF-NAME FONT)
|
||||
(XLFD-FAMILY XLFD)
|
||||
(FIRST (BF-SIZE FONT))
|
||||
(XLFD-PIXEL昤IZE XLFD)
|
||||
(XLFD-POINT昤IZE XLFD)
|
||||
(XLFD-WEIGHT XLFD)
|
||||
(XLFD-SLANT XLFD)
|
||||
(XLFD-SETWIDTH昧AME XLFD)
|
||||
(LENGTH (BF-GLYPHS FONT))
|
||||
(LENGTH (BF-UNMAPPED故LYPHS FONT))))
|
||||
FONT))
|
||||
(FORMAT *STANDARD-OUTPUT* "Name: ~A~%Family: ~A~%Sizes: Font: ~A Pixel: ~A Point: ~A (decipoints)~%Weight: ~A~%Slant: ~A~%Expansion: ~A~%"
|
||||
(BF-NAME FONT)
|
||||
(XLFD-FAMILY XLFD)
|
||||
(FIRST (BF-SIZE FONT))
|
||||
(XLFD-PIXEL昤IZE XLFD)
|
||||
(XLFD-POINT昤IZE XLFD)
|
||||
(XLFD-WEIGHT XLFD)
|
||||
(XLFD-SLANT XLFD)
|
||||
(XLFD-SETWIDTH昧AME XLFD)))
|
||||
FONT)))
|
||||
|
||||
(DEFUN READ-DELIMITED-LIST-FROM-STRING (INPUT-STRING &OPTIONAL (DELIMIT #\]))
|
||||
(IL:* IL:\; "Edited 20-Aug-2024 16:46 by mth")
|
||||
(WITH-INPUT-FROM-STRING (SI (CONCATENATE 'STRING INPUT-STRING " " (STRING DELIMIT)))
|
||||
(READ-DELIMITED-LIST DELIMIT SI)))
|
||||
|
||||
(DEFUN READ-GLYPH (FILE-STREAM FONT &KEY MCCS-ONLY AS-UNICODE)
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 15:32 by mth")
|
||||
(IL:* IL:\; "Edited 23-Feb-2026 20:11 by mth")
|
||||
(IL:* IL:\; "Edited 19-Feb-2026 15:46 by mth")
|
||||
(IL:* IL:\; "Edited 26-Nov-2025 23:32 by mth")
|
||||
(DEFUN READ-GLYPH (FILE-STREAM FONT) (IL:* IL:\; "Edited 26-Nov-2025 23:32 by mth")
|
||||
(IL:* IL:\; "Edited 17-Nov-2025 20:03 by mth")
|
||||
(IL:* IL:\; "Edited 23-Apr-2025 17:53 by mth")
|
||||
(IL:* IL:\; "Edited 21-Apr-2025 13:37 by mth")
|
||||
(IL:* IL:\; "Edited 19-Apr-2025 09:32 by mth")
|
||||
(IL:* IL:\; "Edited 17-Apr-2025 18:14 by mth")
|
||||
(IL:* IL:\; "Edited 21-Aug-2024 01:10 by mth")
|
||||
(LET
|
||||
((GLYPH (MAKE-GLYPH :SWIDTH (COPY-LIST (BF-SWIDTH FONT))
|
||||
:DWIDTH
|
||||
(COPY-LIST (BF-DWIDTH FONT))
|
||||
:SWIDTH1
|
||||
(COPY-LIST (BF-SWIDTH1 FONT))
|
||||
:DWIDTH1
|
||||
(COPY-LIST (BF-DWIDTH1 FONT))
|
||||
:VVECTOR
|
||||
(COPY-LIST (BF-VVECTOR FONT))))
|
||||
CHAR-COMPLETE ENC LINE ITEMS V KEY POS STARTED BBW BBH)
|
||||
(LOOP
|
||||
:UNTIL CHAR-COMPLETE :DO (SETQ LINE (READ-LINE FILE-STREAM))
|
||||
(WHEN LINE (IL:* IL:\; "Ignore blank lines")
|
||||
(MULTIPLE-VALUE-SETQ (KEY POS)
|
||||
(READ-FROM-STRING LINE))
|
||||
(WHEN (<= POS (LENGTH LINE))
|
||||
(SETQ LINE (SUBSEQ LINE POS)))
|
||||
(COND
|
||||
((EQ KEY 'COMMENT) (IL:* IL:\; "Ignore COMMENT lines")
|
||||
(LET ((GLYPH (MAKE-GLYPH :SWIDTH (COPY-LIST (BF-SWIDTH FONT))
|
||||
:DWIDTH
|
||||
(COPY-LIST (BF-DWIDTH FONT))
|
||||
:SWIDTH1
|
||||
(COPY-LIST (BF-SWIDTH1 FONT))
|
||||
:DWIDTH1
|
||||
(COPY-LIST (BF-DWIDTH1 FONT))
|
||||
:VVECTOR
|
||||
(COPY-LIST (BF-VVECTOR FONT))))
|
||||
CHAR-COMPLETE LINE ITEMS V KEY POS STARTED BBW BBH)
|
||||
(LOOP :UNTIL CHAR-COMPLETE :DO (SETQ LINE (READ-LINE FILE-STREAM))
|
||||
(WHEN LINE (IL:* IL:\; "Ignore blank lines")
|
||||
(MULTIPLE-VALUE-SETQ (KEY POS)
|
||||
(READ-FROM-STRING LINE))
|
||||
(WHEN (<= POS (LENGTH LINE))
|
||||
(SETQ LINE (SUBSEQ LINE POS)))
|
||||
(COND
|
||||
((EQ KEY 'COMMENT) (IL:* IL:\; "Ignore COMMENT lines")
|
||||
(IL:* IL:\;
|
||||
"Probably aren't \"legal\" here, anyway.")
|
||||
)
|
||||
((EQ KEY 'STARTCHAR)
|
||||
(WHEN STARTED (ERROR "Invalid BDF file - STARTCHAR inside glyph."))
|
||||
(SETF STARTED T)
|
||||
(SETF (GLYPH-NAME GLYPH)
|
||||
(STRING LINE)))
|
||||
(T
|
||||
(UNLESS STARTED (ERROR
|
||||
)
|
||||
((EQ KEY 'STARTCHAR)
|
||||
(WHEN STARTED (ERROR "Invalid BDF file - STARTCHAR inside glyph."))
|
||||
(SETF STARTED T)
|
||||
(SETF (GLYPH-NAME GLYPH)
|
||||
(STRING LINE)))
|
||||
(T (UNLESS STARTED (ERROR
|
||||
"Invalid BDF file - glyph has not been started. STARTCHAR missing."
|
||||
))
|
||||
(SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE))
|
||||
(CASE KEY
|
||||
(ENCODING (SETF (GLYPH-ENCODING GLYPH)
|
||||
(SETQ ENC (IF (EQL -1 (FIRST ITEMS))
|
||||
ITEMS
|
||||
(FIRST ITEMS)))))
|
||||
(SWIDTH (SETF (GLYPH-SWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH (SETF (GLYPH-DWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(SWIDTH1 (SETF (GLYPH-SWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH1 (SETF (GLYPH-DWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(VVECTOR (SETF (GLYPH-VVECTOR GLYPH)
|
||||
ITEMS))
|
||||
(BBX (SETF (GLYPH-BBW GLYPH)
|
||||
(SETQ BBW (FIRST ITEMS))
|
||||
(GLYPH-BBH GLYPH)
|
||||
(SETQ BBH (SECOND ITEMS))
|
||||
(GLYPH-BBXOFF0 GLYPH)
|
||||
(THIRD ITEMS)
|
||||
(GLYPH-BBYOFF0 GLYPH)
|
||||
(FOURTH ITEMS)))
|
||||
(BITMAP
|
||||
(UNLESS (ZEROP (* BBW BBH)) (IL:* IL:\;
|
||||
"Don't bother creating a BITMAP with no area")
|
||||
(IF (AND (NOT AS-UNICODE)
|
||||
MCCS-ONLY
|
||||
(NOT (UTOMCODE? ENC)))
|
||||
(PROGN
|
||||
(IL:* IL:|;;|
|
||||
"This is the case of skipping over non-MCCS encoded glyph when MCCS-ONLY")
|
||||
))
|
||||
(SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE))
|
||||
(CASE KEY
|
||||
(ENCODING (SETF (GLYPH-ENCODING GLYPH)
|
||||
(IF (EQL -1 (FIRST ITEMS))
|
||||
ITEMS
|
||||
(FIRST ITEMS))))
|
||||
(SWIDTH (SETF (GLYPH-SWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH (SETF (GLYPH-DWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(SWIDTH1 (SETF (GLYPH-SWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH1 (SETF (GLYPH-DWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(VVECTOR (SETF (GLYPH-VVECTOR GLYPH)
|
||||
ITEMS))
|
||||
(BBX (SETF (GLYPH-BBW GLYPH)
|
||||
(SETQ BBW (FIRST ITEMS))
|
||||
(GLYPH-BBH GLYPH)
|
||||
(SETQ BBH (SECOND ITEMS))
|
||||
(GLYPH-BBXOFF0 GLYPH)
|
||||
(THIRD ITEMS)
|
||||
(GLYPH-BBYOFF0 GLYPH)
|
||||
(FOURTH ITEMS)))
|
||||
(BITMAP (UNLESS (ZEROP (* BBW BBH))
|
||||
|
||||
(LOOP :REPEAT BBH :DO (READ-LINE FILE-STREAM)))
|
||||
(LET*
|
||||
((BM (BITMAPCREATE BBW BBH 1))
|
||||
(BM.BASE (IL:|fetch| IL:BITMAPBASE IL:|of| BM))
|
||||
(BM.RASTERWIDTH (IL:|fetch| IL:BITMAPRASTERWIDTH IL:|of| BM))
|
||||
(NBYTES (CEILING BBW 8))
|
||||
(NCHARS (* 2 NBYTES))
|
||||
(NWORDS (CEILING BBW 16))
|
||||
BITS WORDINDEX)
|
||||
(LABELS ((CHAR-HEX-VALUE (C)
|
||||
(IF (CHARACTERP C)
|
||||
(COND
|
||||
((CHAR<= #\0 C #\9)
|
||||
(- (CHAR-CODE C)
|
||||
(IL:CONSTANT (CHAR-CODE #\0))))
|
||||
((CHAR<= #\A C #\F)
|
||||
(IL:* IL:|;;| "Don't bother creating a BITMAP with no area")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"The (- (CHAR-CODE #\\A) 10) accomplishes adding 10 after the outer subtraction")
|
||||
|
||||
(- (CHAR-CODE C)
|
||||
(IL:CONSTANT (- (CHAR-CODE #\A)
|
||||
10))))
|
||||
((CHAR<= #\a C #\f)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"The (- (CHAR-CODE #\\a) 10) accomplishes adding 10 after the outer subtraction")
|
||||
|
||||
(- (CHAR-CODE C)
|
||||
(IL:CONSTANT (- (CHAR-CODE #\a)
|
||||
10))))
|
||||
(T 0))
|
||||
0))
|
||||
(PARSE-WORDS
|
||||
NIL
|
||||
(LOOP :FOR I :FROM 0 :TO (1- NCHARS)
|
||||
:BY 4 :WITH C3LIMIT = (- NCHARS 3)
|
||||
:WITH C4LIMIT = (- NCHARS 4)
|
||||
:COLLECT
|
||||
(+ (ASH (CHAR-HEX-VALUE (CHAR LINE I))
|
||||
12)
|
||||
(ASH (CHAR-HEX-VALUE (CHAR LINE (+ 1 I)))
|
||||
8)
|
||||
(ASH (CHAR-HEX-VALUE (AND (<= I C3LIMIT)
|
||||
(CHAR LINE (+ 2 I))))
|
||||
4)
|
||||
(CHAR-HEX-VALUE (AND (<= I C4LIMIT)
|
||||
(CHAR LINE (+ 3 I))))))))
|
||||
(LOOP :WITH BITROW = 0 :REPEAT BBH :DO
|
||||
(SETQ LINE (STRING-TRIM '(#\Space #\Tab)
|
||||
(READ-LINE FILE-STREAM)))
|
||||
(UNLESS (EQUAL NCHARS (LENGTH LINE))
|
||||
(ERROR "Invalid BDF file - bad line in BITMAP: ~A"
|
||||
LINE))
|
||||
(SETQ BITS (PARSE-WORDS))
|
||||
(SETQ WORDINDEX (* BITROW BM.RASTERWIDTH))
|
||||
(LOOP :REPEAT NWORDS :DO (IL:\\PUTBASE BM.BASE WORDINDEX
|
||||
(POP BITS))
|
||||
(INCF WORDINDEX))
|
||||
(INCF BITROW)))
|
||||
(SETF (GLYPH-BITMAP GLYPH)
|
||||
BM)))))
|
||||
(ENDCHAR (SETQ CHAR-COMPLETE T)))))))
|
||||
(SETF (GLYPH-ASCENT GLYPH)
|
||||
(+ (GLYPH-BBH GLYPH)
|
||||
(GLYPH-BBYOFF0 GLYPH)))
|
||||
(SETF (GLYPH-DESCENT GLYPH)
|
||||
(ABS (MIN 0 (GLYPH-BBYOFF0 GLYPH))))
|
||||
(SETF (GLYPH-WIDTH GLYPH)
|
||||
(MAX (+ (MAX 0 (GLYPH-BBXOFF0 GLYPH))
|
||||
(GLYPH-BBW GLYPH))
|
||||
(FIRST (GLYPH-DWIDTH GLYPH))))
|
||||
GLYPH))
|
||||
(LET* ((BM (BITMAPCREATE BBW BBH 1))
|
||||
(BM.BASE (IL:|fetch| IL:BITMAPBASE IL:|of| BM))
|
||||
(BM.RASTERWIDTH (IL:|fetch| IL:BITMAPRASTERWIDTH
|
||||
IL:|of| BM))
|
||||
(NBYTES (CEILING BBW 8))
|
||||
(NCHARS (* 2 NBYTES))
|
||||
(NWORDS (CEILING BBW 16))
|
||||
BITS BYTEPOS WORDINDEX)
|
||||
(LOOP :WITH BITROW = 0 :REPEAT BBH :DO
|
||||
(SETQ LINE (STRING-TRIM '(#\Space #\Tab)
|
||||
(READ-LINE FILE-STREAM)))
|
||||
(UNLESS (AND (EQUAL NCHARS (LENGTH LINE))
|
||||
(SETQ BITS
|
||||
(PARSE-INTEGER LINE :RADIX 16
|
||||
:JUNK-ALLOWED T)))
|
||||
(ERROR
|
||||
"Invalid BDF file - bad line in BITMAP: ~A"
|
||||
LINE))
|
||||
(WHEN (ODDP NBYTES)
|
||||
(SETQ BITS (ASH BITS 8)))
|
||||
(SETQ WORDINDEX (* BITROW BM.RASTERWIDTH))
|
||||
(SETQ BYTEPOS (* 16 (1- NWORDS)))
|
||||
(LOOP :REPEAT NWORDS :DO
|
||||
(IL:\\PUTBASE BM.BASE WORDINDEX
|
||||
(LDB (BYTE 16 BYTEPOS)
|
||||
BITS))
|
||||
(INCF WORDINDEX)
|
||||
(DECF BYTEPOS 16))
|
||||
(INCF BITROW))
|
||||
(SETF (GLYPH-BITMAP GLYPH)
|
||||
BM))))
|
||||
(ENDCHAR (SETQ CHAR-COMPLETE T)))))))
|
||||
(SETF (GLYPH-ASCENT GLYPH)
|
||||
(+ (GLYPH-BBH GLYPH)
|
||||
(GLYPH-BBYOFF0 GLYPH)))
|
||||
(SETF (GLYPH-DESCENT GLYPH)
|
||||
(ABS (MIN 0 (GLYPH-BBYOFF0 GLYPH))))
|
||||
(SETF (GLYPH-WIDTH GLYPH)
|
||||
(MAX (+ (MAX 0 (GLYPH-BBXOFF0 GLYPH))
|
||||
(GLYPH-BBW GLYPH))
|
||||
(FIRST (GLYPH-DWIDTH GLYPH))))
|
||||
GLYPH))
|
||||
|
||||
(DEFUN WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE (BDFONT DEST-DIR &KEY FAMILY SIZE FACE ROTATION DEVICE
|
||||
AS-UNICODE TEST &AUX FULLFILENAME)
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 16:12 by mth")
|
||||
(IL:* IL:\; "Edited 23-Feb-2026 15:57 by mth")
|
||||
(IL:* IL:\; "Edited 17-Feb-2026 14:17 by mth")
|
||||
&AUX FULLFILENAME)
|
||||
(IL:* IL:\; "Edited 2-Dec-2025 14:47 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 16:03 by mth")
|
||||
(IL:* IL:\; "Edited 28-Nov-2025 17:56 by mth")
|
||||
@@ -868,7 +760,7 @@
|
||||
(UNLESS (BDF-FONT-P BDFONT)
|
||||
(ERROR "Not a BDF-FONT: ~S ~%" BDFONT))
|
||||
(DESTRUCTURING-BIND (FONTDESC CSETS)
|
||||
(BDF-TO-FONTDESCRIPTOR BDFONT FAMILY SIZE FACE ROTATION DEVICE :AS-UNICODE AS-UNICODE)
|
||||
(BDF-TO-FONTDESCRIPTOR BDFONT FAMILY SIZE FACE ROTATION DEVICE)
|
||||
(UNLESS FONTDESC
|
||||
|
||||
(IL:* IL:|;;| "Creation of the FONTDESCRIPTOR failed!")
|
||||
@@ -877,10 +769,8 @@
|
||||
|
||||
(IL:* IL:|;;| "CSETS correspond to the charsets actually present in the FONTDESC.")
|
||||
|
||||
(SETQ FULLFILENAME (IF TEST
|
||||
"WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE TEST"
|
||||
(MEDLEYFONT.WRITE.FONT FONTDESC (MEDLEYFONT.FILENAME NIL FONTDESC
|
||||
NIL NIL DEST-DIR))))
|
||||
(SETQ FULLFILENAME (MEDLEYFONT.WRITE.FONT FONTDESC (MEDLEYFONT.FILENAME FONTDESC NIL NIL
|
||||
DEST-DIR)))
|
||||
(LIST FULLFILENAME FONTDESC CSETS)))
|
||||
|
||||
(DEFUN XLFD-SPLIT-FONT-NAME (NAME) (IL:* IL:\; "Edited 26-Nov-2025 09:43 by mth")
|
||||
@@ -990,21 +880,21 @@
|
||||
"BITMAPCREATE" "BITMAPHEIGHT"
|
||||
"BITMAPWIDTH" "BLACKSHADE" "BLTSHADE"
|
||||
"BOLD" "COMPRESSED" "CHARSETINFO"
|
||||
"DISPLAY" "FONTDESCRIPTOR" "FONTP"
|
||||
"FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH"
|
||||
"MCCS" "MEDIUM" "REGULAR" "TCONC"
|
||||
"UTOMCODE?" "MEDLEYFONT.FILENAME"
|
||||
"CHARSETPROP" "DISPLAY" "FONTDESCRIPTOR"
|
||||
"FONTP" "FONTPROP" "INPUT" "ITALIC"
|
||||
"LIGHT" "LRSH" "MCCS" "MEDIUM" "REGULAR"
|
||||
"TCONC" "UTOMCODE?" "MEDLEYFONT.FILENAME"
|
||||
"MEDLEYFONT.WRITE.FONT"))
|
||||
:READTABLE "XCL"
|
||||
:COMPILER :COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS IL:READ-BDF IL:DATABASE IL:NO)
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (3216 10679 (BDF-TO-CHARSETINFO 3216 . 10679)) (10681 17828 (BDF-TO-FONTDESCRIPTOR
|
||||
10681 . 17828)) (17830 22409 (BUILD-COMPOSITE 17830 . 22409)) (22411 23160 (CHAR-PRESENT-BIT 22411 .
|
||||
23160)) (23162 23446 (COUNT-MCHARS 23162 . 23446)) (23448 26592 (GLYPHS-BY-CHARSET 23448 . 26592)) (
|
||||
26594 28019 (PACKFILENAME.STRING 26594 . 28019)) (28021 40051 (READ-BDF 28021 . 40051)) (40053 40376 (
|
||||
READ-DELIMITED-LIST-FROM-STRING 40053 . 40376)) (40378 49390 (READ-GLYPH 40378 . 49390)) (49392 51271
|
||||
(WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE 49392 . 51271)) (51273 53690 (XLFD-SPLIT-FONT-NAME 51273 . 53690)
|
||||
) (53692 56704 (XLFD-TO-FACE 53692 . 56704)))))
|
||||
(IL:FILEMAP (NIL (3116 10226 (BDF-TO-CHARSETINFO 3116 . 10226)) (10228 16847 (BDF-TO-FONTDESCRIPTOR
|
||||
10228 . 16847)) (16849 20782 (BUILD-COMPOSITE 16849 . 20782)) (20784 21533 (CHAR-PRESENT-BIT 20784 .
|
||||
21533)) (21535 21819 (COUNT-MCHARS 21535 . 21819)) (21821 24856 (GLYPHS-BY-CHARSET 21821 . 24856)) (
|
||||
24858 26283 (PACKFILENAME.STRING 24858 . 26283)) (26285 35760 (READ-BDF 26285 . 35760)) (35762 36085 (
|
||||
READ-DELIMITED-LIST-FROM-STRING 35762 . 36085)) (36087 43085 (READ-GLYPH 36087 . 43085)) (43087 44472
|
||||
(WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE 43087 . 44472)) (44474 46891 (XLFD-SPLIT-FONT-NAME 44474 . 46891)
|
||||
) (46893 49905 (XLFD-TO-FACE 46893 . 49905)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
@@ -57,7 +57,12 @@ main() {
|
||||
|
||||
# save dribble file to loadups; extract and save fails
|
||||
"${MEDLEYDIR}"/scripts/cpv ${logindir}/HCFILES.DRIBBLE "${MEDLEYDIR}"/loadups/hcfiles.dribble
|
||||
grep "IL:FAIL" < "${MEDLEYDIR}"/loadups/hcfiles.dribble > ${logindir}/fails
|
||||
if [ -f "$(command -v perl)" ] && [ -x "$(command -v perl)" ]
|
||||
then
|
||||
perl "${MEDLEYDIR}"/scripts/getFails.pl '^[^\n]*IL:FAIL' 'DONE' "${MEDLEYDIR}"/loadups/hcfiles.dribble > ${logindir}/fails
|
||||
else
|
||||
echo Unable to extract FAIL information from "${MEDLEYDIR}"/loadups/hcfiles.dribble > ${logindir}/fails
|
||||
fi
|
||||
"${MEDLEYDIR}"/scripts/cpv ${logindir}/fails "${MEDLEYDIR}"/loadups/hcfiles-fails.txt
|
||||
|
||||
# cleanup
|
||||
|
||||
31
scripts/getFails.pl
Normal file
31
scripts/getFails.pl
Normal file
@@ -0,0 +1,31 @@
|
||||
#!/usr/bin/env perl
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
die "Usage: $0 <pattern1> <pattern2> [file...]\n" unless @ARGV >= 2;
|
||||
|
||||
my $pat1 = shift;
|
||||
my $pat2 = shift;
|
||||
my $regex1line = qr/${pat1}.*?${pat2}/; # all on 1 line
|
||||
my $regexStart = qr/${pat1}/; # the line has the start pattern
|
||||
my $regexEnd = qr/${pat2}/; # the line has the end pattern
|
||||
|
||||
my $flag = 0;
|
||||
|
||||
while (<>) {
|
||||
if ($flag) { # we're in a multi-line block
|
||||
print;
|
||||
if (/$regexEnd/) { # does this line end the multi-line block?
|
||||
$flag = 0;
|
||||
print "\n"; # separator
|
||||
};
|
||||
}
|
||||
elsif (/$regex1line/) { # all on 1 line
|
||||
print;
|
||||
print "\n"; # separator
|
||||
}
|
||||
elsif (/$regexStart/) { # begin a multi-line block
|
||||
print;
|
||||
$flag = 1;
|
||||
}
|
||||
}
|
||||
147
sources/FILEIO
147
sources/FILEIO
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED " 6-Feb-2026 23:22:00" {WMEDLEY}<sources>FILEIO.;142 166519
|
||||
(FILECREATED "26-Apr-2026 23:27:40" {WMEDLEY}<sources>FILEIO.;146 165936
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS DIRECTORYNAME)
|
||||
:CHANGES-TO (FNS \DO.PARAMS.AT.OPEN)
|
||||
|
||||
:PREVIOUS-DATE "12-Sep-2025 08:19:06" {WMEDLEY}<sources>FILEIO.;141)
|
||||
:PREVIOUS-DATE "26-Apr-2026 21:00:55" {WMEDLEY}<sources>FILEIO.;145)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT FILEIOCOMS)
|
||||
@@ -1446,7 +1446,10 @@
|
||||
(GO RETRY])
|
||||
|
||||
(\DO.PARAMS.AT.OPEN
|
||||
[LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 25-Dec-2024 10:54 by rmk")
|
||||
[LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 26-Apr-2026 23:27 by rmk")
|
||||
(* ; "Edited 21-Apr-2026 20:57 by mth")
|
||||
(* ; "Edited 20-Apr-2026 17:36 by mth")
|
||||
(* ; "Edited 25-Dec-2024 10:54 by rmk")
|
||||
(* ; "Edited 15-Jul-2024 22:29 by rmk")
|
||||
(* ; "Edited 25-Aug-2023 08:43 by rmk")
|
||||
(* ; "Edited 6-Jul-2022 00:00 by rmk")
|
||||
@@ -1469,44 +1472,40 @@
|
||||
|
||||
(DECLARE (USEDFREE STREAM-AFTER-OPEN-FNS))
|
||||
(\EXTERNALFORMAT STREAM :DEFAULT)
|
||||
[for X ATTR VAL EOL in PARAMETERS do [(COND
|
||||
[(LISTP X)
|
||||
(SETQ ATTR (CAR X))
|
||||
(SETQ VAL (CAR (LISTP (CDR X]
|
||||
(T (SETQ ATTR X)
|
||||
(SETQ VAL T)))
|
||||
(SELECTQ ATTR
|
||||
(BUFFERS (SETFILEINFO STREAM 'BUFFERS VAL))
|
||||
(ENDOFSTREAMOP (SETFILEINFO STREAM 'ENDOFSTREAMOP VAL))
|
||||
(CHARSET (CHARSET STREAM VAL))
|
||||
((FORMAT EXTERNALFORMAT :EXTERNAL-FORMAT)
|
||||
(for X ATTR VAL EOL in PARAMETERS
|
||||
do (COND
|
||||
[(LISTP X)
|
||||
(SETQ ATTR (CAR X))
|
||||
(SETQ VAL (CAR (LISTP (CDR X]
|
||||
(T (SETQ ATTR X)
|
||||
(SETQ VAL T)))
|
||||
(SELECTQ ATTR
|
||||
(BUFFERS (SETFILEINFO STREAM 'BUFFERS VAL))
|
||||
(ENDOFSTREAMOP (SETFILEINFO STREAM 'ENDOFSTREAMOP VAL))
|
||||
(CHARSET (CHARSET STREAM VAL))
|
||||
((FORMAT EXTERNALFORMAT :EXTERNAL-FORMAT)
|
||||
(* ;;
|
||||
"This allows an EOL and format to be intermixed, the last ones of each are installed")
|
||||
|
||||
(* ;;
|
||||
"VAL can be :UTF-8, CR, (UTF:8 CR), i.e. specify either one or both")
|
||||
(for V inside VAL do (if (MEMB V '(LF CR CRLF ANY))
|
||||
then (SETQ EOL V)
|
||||
else (\EXTERNALFORMAT STREAM V))))
|
||||
(CONVHANKAKU (CONVHANKAKU STREAM VAL))
|
||||
((EOL EOLCONVENTION EOLC)
|
||||
(SETQ EOL VAL))
|
||||
NIL) finally
|
||||
|
||||
(if (LISTP VAL)
|
||||
then (* ;
|
||||
"VAL could be (:UTF-8 CR) e.g. from CL:OPEN")
|
||||
(\EXTERNALFORMAT STREAM (CAR VAL))
|
||||
(* ;
|
||||
"Can override the EOL of the format")
|
||||
(SETQ EOL (CADR VAL))
|
||||
elseif (SETQ EOL (CAR)
|
||||
VAL)
|
||||
else (\EXTERNALFORMAT STREAM VAL)))
|
||||
(CONVHANKAKU (CONVHANKAKU STREAM VAL))
|
||||
((EOL EOLCONVENTION EOLC)
|
||||
(SETQ EOL VAL] finally
|
||||
(* ;; "If EOL is not specified, default input streams to ANY. ")
|
||||
|
||||
(* ;;
|
||||
"If not specified, default EOL to ANY--SETFILEINFO checks for output streams")
|
||||
|
||||
(SETFILEINFO STREAM 'EOL
|
||||
(OR EOL 'ANY]
|
||||
(FOR FN IN STREAM-AFTER-OPEN-FNS DO (APPLY* FN STREAM ACCESS PARAMETERS])
|
||||
(CL:UNLESS (OR EOL (\GETSTREAM STREAM 'OUTPUT T))
|
||||
(SETQ EOL 'ANY))
|
||||
(CL:WHEN EOL
|
||||
(SETFILEINFO STREAM 'EOL EOL)))
|
||||
(for FN in STREAM-AFTER-OPEN-FNS do (APPLY* FN STREAM ACCESS PARAMETERS])
|
||||
|
||||
(\RENAMEFILE
|
||||
[LAMBDA (OLDFILE NEWFILE) (* ; "Edited 25-Dec-2024 10:14 by rmk")
|
||||
[LAMBDA (OLDFILE NEWFILE) (* ; "Edited 25-Apr-2026 16:03 by rmk")
|
||||
(* ; "Edited 25-Dec-2024 10:14 by rmk")
|
||||
(* ; "Edited 16-Dec-2024 21:07 by rmk")
|
||||
(* hdj " 7-May-86 12:22")
|
||||
(SETQ OLDFILE (\ADD.CONNECTED.DIR OLDFILE))
|
||||
@@ -1521,7 +1520,7 @@
|
||||
NEW-DEVICE
|
||||
(TRUEFILENAME NEWFILE)))
|
||||
(CL:IF (PSEUDOHOSTP NEWFILE)
|
||||
(PSEUDOFILENAME NEWFULLNAME)
|
||||
(PSEUDOFILENAME NEWFULLNAME (FILENAMEFIELD NEWFILE 'HOST))
|
||||
NEWFULLNAME))])
|
||||
|
||||
(\REVALIDATEFILE
|
||||
@@ -3161,39 +3160,39 @@ update the map")
|
||||
(ADDTOVAR LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (27706 31822 (STREAMPROP 27716 . 28150) (GETSTREAMPROP 28152 . 28901) (PUTSTREAMPROP
|
||||
28903 . 31670) (STREAMP 31672 . 31820)) (31865 35244 (\DEFPRINT.BY.NAME 31875 . 33027) (
|
||||
\STREAM.DEFPRINT 33029 . 34937) (\FDEV.DEFPRINT 34939 . 35242)) (35502 40543 (\GETACCESS 35512 . 35966
|
||||
) (\SETACCESS 35968 . 40541)) (60769 66738 (\DEFINEDEVICE 60779 . 63095) (\GETDEVICEFROMNAME 63097 .
|
||||
63570) (\GETDEVICEFROMHOSTNAME 63572 . 64616) (\REMOVEDEVICE 64618 . 65741) (\REMOVEDEVICE.NAMES 65743
|
||||
. 66736)) (66778 94509 (\CLOSEFILE 66788 . 67613) (\DELETEFILE 67615 . 67909) (\DEVICEEVENT 67911 .
|
||||
69681) (\GENERATEFILES 69683 . 70630) (\GENERATENEXTFILE 70632 . 71283) (\GENERATEFILEINFO 71285 .
|
||||
71746) (\GETFILENAME 71748 . 72137) (\GENERIC.OUTFILEP 72139 . 72609) (\OPENFILE 72611 . 75189) (
|
||||
\DO.PARAMS.AT.OPEN 75191 . 79387) (\RENAMEFILE 79389 . 80345) (\REVALIDATEFILE 80347 . 82949) (
|
||||
\PAGED.REVALIDATEFILELST 82951 . 84509) (\PAGED.REVALIDATEFILES 84511 . 86230) (\PAGED.REVALIDATEFILE
|
||||
86232 . 88515) (\BUFFERED.REVALIDATEFILE 88517 . 90803) (\BUFFERED.REVALIDATEFILELST 90805 . 91989) (
|
||||
\PRINT-REVALIDATION-RESULT 91991 . 92833) (\TRUNCATEFILE 92835 . 93226) (\FILE-CONFLICT 93228 . 94507)
|
||||
) (94545 99208 (\GENERATENOFILES 94555 . 96651) (\NULLFILEGENERATOR 96653 . 96897) (\NOFILESNEXTFILEFN
|
||||
96899 . 98890) (\NOFILESINFOFN 98892 . 99206)) (99327 101235 (\FILE.NOT.OPEN 99337 . 99850) (
|
||||
\FILE.WONT.OPEN 99852 . 100180) (\ILLEGAL.DEVICEOP 100182 . 100464) (\IS.NOT.RANDACCESSP 100466 .
|
||||
100912) (\STREAM.NOT.OPEN 100914 . 101233)) (101370 103668 (\FDEVINSTANCE 101380 . 103666)) (104870
|
||||
111841 (CNDIR 104880 . 106185) (DIRECTORYNAME 106187 . 109967) (DIRECTORYNAMEP 109969 . 110585) (
|
||||
HOSTNAMEP 110587 . 111394) (\ADD.CONNECTED.DIR 111396 . 111839)) (111886 140833 (\BACKFILEPTR 111896
|
||||
. 112084) (\BACKPEEKBIN 112086 . 112447) (\BACKBIN 112449 . 112800) (BIN 112802 . 113019) (\BIN
|
||||
113021 . 113298) (\BINS 113300 . 113586) (BOUT 113588 . 113950) (\BOUT 113952 . 114267) (\BOUTS 114269
|
||||
. 114580) (COPYBYTES 114582 . 117914) (COPYCHARS 117916 . 121714) (COPYFILE 121716 . 123076) (
|
||||
\COPYOPENFILE 123078 . 126277) (\INFER.FILE.TYPE 126279 . 127233) (EOFP 127235 . 127532) (FORCEOUTPUT
|
||||
127534 . 127781) (\FLUSH.OPEN.STREAMS 127783 . 128139) (CHARSET 128141 . 129500) (ACCESS-CHARSET
|
||||
129502 . 130139) (GETEOFPTR 130141 . 130391) (GETFILEINFO 130393 . 133586) (\TYPE.FROM.FILETYPE 133588
|
||||
. 134058) (\FILETYPE.FROM.TYPE 134060 . 134239) (GETFILEPTR 134241 . 134493) (SETFILEINFO 134495 .
|
||||
138732) (SETFILEPTR 138734 . 140453) (BOUT16 140455 . 140640) (BIN16 140642 . 140831)) (140936 148116
|
||||
(\GENERIC.BINS 140946 . 141226) (\GENERIC.BOUTS 141228 . 141493) (\GENERIC.RENAMEFILE 141495 . 143743)
|
||||
(\GENERIC.OPENP 143745 . 145060) (\GENERIC.READP 145062 . 146214) (\GENERIC.CHARSET 146216 . 148114))
|
||||
(148117 148456 (\MAP-OPEN-STREAMS 148127 . 148454)) (150311 152391 (\EOF.ACTION 150321 . 150572) (
|
||||
\EOSERROR 150574 . 150767) (\GETEOFPTR 150769 . 150951) (\INCFILEPTR 150953 . 151303) (\PEEKBIN 151305
|
||||
. 151496) (\SETCLOSEDFILELENGTH 151498 . 151832) (\SETEOFPTR 151834 . 152022) (\SETFILEPTR 152024 .
|
||||
152389)) (152392 152934 (\FIXPOUT 152402 . 152702) (\FIXPIN 152704 . 152932)) (152935 153501 (\BOUTEOL
|
||||
152945 . 153499)) (156397 166261 (\BUFFERED.BIN 156407 . 157259) (\BUFFERED.PEEKBIN 157261 . 158043)
|
||||
(\BUFFERED.BOUT 158045 . 158905) (\BUFFERED.BINS 158907 . 162592) (\BUFFERED.BOUTS 162594 . 164395) (
|
||||
\BUFFERED.COPYBYTES 164397 . 166259)))))
|
||||
(FILEMAP (NIL (27711 31827 (STREAMPROP 27721 . 28155) (GETSTREAMPROP 28157 . 28906) (PUTSTREAMPROP
|
||||
28908 . 31675) (STREAMP 31677 . 31825)) (31870 35249 (\DEFPRINT.BY.NAME 31880 . 33032) (
|
||||
\STREAM.DEFPRINT 33034 . 34942) (\FDEV.DEFPRINT 34944 . 35247)) (35507 40548 (\GETACCESS 35517 . 35971
|
||||
) (\SETACCESS 35973 . 40546)) (60774 66743 (\DEFINEDEVICE 60784 . 63100) (\GETDEVICEFROMNAME 63102 .
|
||||
63575) (\GETDEVICEFROMHOSTNAME 63577 . 64621) (\REMOVEDEVICE 64623 . 65746) (\REMOVEDEVICE.NAMES 65748
|
||||
. 66741)) (66783 93926 (\CLOSEFILE 66793 . 67618) (\DELETEFILE 67620 . 67914) (\DEVICEEVENT 67916 .
|
||||
69686) (\GENERATEFILES 69688 . 70635) (\GENERATENEXTFILE 70637 . 71288) (\GENERATEFILEINFO 71290 .
|
||||
71751) (\GETFILENAME 71753 . 72142) (\GENERIC.OUTFILEP 72144 . 72614) (\OPENFILE 72616 . 75194) (
|
||||
\DO.PARAMS.AT.OPEN 75196 . 78665) (\RENAMEFILE 78667 . 79762) (\REVALIDATEFILE 79764 . 82366) (
|
||||
\PAGED.REVALIDATEFILELST 82368 . 83926) (\PAGED.REVALIDATEFILES 83928 . 85647) (\PAGED.REVALIDATEFILE
|
||||
85649 . 87932) (\BUFFERED.REVALIDATEFILE 87934 . 90220) (\BUFFERED.REVALIDATEFILELST 90222 . 91406) (
|
||||
\PRINT-REVALIDATION-RESULT 91408 . 92250) (\TRUNCATEFILE 92252 . 92643) (\FILE-CONFLICT 92645 . 93924)
|
||||
) (93962 98625 (\GENERATENOFILES 93972 . 96068) (\NULLFILEGENERATOR 96070 . 96314) (\NOFILESNEXTFILEFN
|
||||
96316 . 98307) (\NOFILESINFOFN 98309 . 98623)) (98744 100652 (\FILE.NOT.OPEN 98754 . 99267) (
|
||||
\FILE.WONT.OPEN 99269 . 99597) (\ILLEGAL.DEVICEOP 99599 . 99881) (\IS.NOT.RANDACCESSP 99883 . 100329)
|
||||
(\STREAM.NOT.OPEN 100331 . 100650)) (100787 103085 (\FDEVINSTANCE 100797 . 103083)) (104287 111258 (
|
||||
CNDIR 104297 . 105602) (DIRECTORYNAME 105604 . 109384) (DIRECTORYNAMEP 109386 . 110002) (HOSTNAMEP
|
||||
110004 . 110811) (\ADD.CONNECTED.DIR 110813 . 111256)) (111303 140250 (\BACKFILEPTR 111313 . 111501) (
|
||||
\BACKPEEKBIN 111503 . 111864) (\BACKBIN 111866 . 112217) (BIN 112219 . 112436) (\BIN 112438 . 112715)
|
||||
(\BINS 112717 . 113003) (BOUT 113005 . 113367) (\BOUT 113369 . 113684) (\BOUTS 113686 . 113997) (
|
||||
COPYBYTES 113999 . 117331) (COPYCHARS 117333 . 121131) (COPYFILE 121133 . 122493) (\COPYOPENFILE
|
||||
122495 . 125694) (\INFER.FILE.TYPE 125696 . 126650) (EOFP 126652 . 126949) (FORCEOUTPUT 126951 .
|
||||
127198) (\FLUSH.OPEN.STREAMS 127200 . 127556) (CHARSET 127558 . 128917) (ACCESS-CHARSET 128919 .
|
||||
129556) (GETEOFPTR 129558 . 129808) (GETFILEINFO 129810 . 133003) (\TYPE.FROM.FILETYPE 133005 . 133475
|
||||
) (\FILETYPE.FROM.TYPE 133477 . 133656) (GETFILEPTR 133658 . 133910) (SETFILEINFO 133912 . 138149) (
|
||||
SETFILEPTR 138151 . 139870) (BOUT16 139872 . 140057) (BIN16 140059 . 140248)) (140353 147533 (
|
||||
\GENERIC.BINS 140363 . 140643) (\GENERIC.BOUTS 140645 . 140910) (\GENERIC.RENAMEFILE 140912 . 143160)
|
||||
(\GENERIC.OPENP 143162 . 144477) (\GENERIC.READP 144479 . 145631) (\GENERIC.CHARSET 145633 . 147531))
|
||||
(147534 147873 (\MAP-OPEN-STREAMS 147544 . 147871)) (149728 151808 (\EOF.ACTION 149738 . 149989) (
|
||||
\EOSERROR 149991 . 150184) (\GETEOFPTR 150186 . 150368) (\INCFILEPTR 150370 . 150720) (\PEEKBIN 150722
|
||||
. 150913) (\SETCLOSEDFILELENGTH 150915 . 151249) (\SETEOFPTR 151251 . 151439) (\SETFILEPTR 151441 .
|
||||
151806)) (151809 152351 (\FIXPOUT 151819 . 152119) (\FIXPIN 152121 . 152349)) (152352 152918 (\BOUTEOL
|
||||
152362 . 152916)) (155814 165678 (\BUFFERED.BIN 155824 . 156676) (\BUFFERED.PEEKBIN 156678 . 157460)
|
||||
(\BUFFERED.BOUT 157462 . 158322) (\BUFFERED.BINS 158324 . 162009) (\BUFFERED.BOUTS 162011 . 163812) (
|
||||
\BUFFERED.COPYBYTES 163814 . 165676)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
323
sources/XCCS
323
sources/XCCS
@@ -1,323 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "13-Jul-2025 23:08:39" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>XCCS.;10 15413
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS XCCSCOMS)
|
||||
|
||||
:PREVIOUS-DATE "25-Mar-2025 23:40:52"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>XCCS.;9)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT XCCSCOMS)
|
||||
|
||||
(RPAQQ XCCSCOMS
|
||||
[(FNS \XCCSINCCODE \XCCSPEEKCCODE \XCCSOUTCHAR \XCCSBACKCCODE \XCCSFORMATBYTESTREAM
|
||||
\XCCSCHARSETFN)
|
||||
(FNS \CREATE.XCCS.EXTERNALFORMAT)
|
||||
(FNS \NSIN.24BITENCODING.ERROR)
|
||||
(FNS KANJICHARSETP CHINESECHARSETP)
|
||||
(INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (CONSTANTS (\NORUNCODE 255)
|
||||
(NSCHARSETSHIFT 255))
|
||||
(MACROS \RUNCODED)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.XCCS.EXTERNALFORMAT])
|
||||
(DEFINEQ
|
||||
|
||||
(\XCCSINCCODE
|
||||
[LAMBDA (STREAM COUNTP) (* ; "Edited 8-Dec-2023 15:28 by rmk")
|
||||
(* ; "Edited 6-Aug-2021 15:57 by rmk:")
|
||||
|
||||
(* ;;; "Returns a 16 bit character code. SHIFTEDCSET is STREAM's char set left shifted 8.")
|
||||
|
||||
(* ;;; "If COUNTP is non-NIL, the variable *BYTECOUNTER* is set freely to the number of bytes read.")
|
||||
|
||||
(* ;;; "This doesn't do EOL conversion, \INCHAR does that")
|
||||
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(\DTEST STREAM 'STREAM)
|
||||
(LET (NUMBYTES (CSET (ffetch (STREAM CHARSET) of STREAM))
|
||||
(CHAR (\BIN STREAM))) (* ;
|
||||
"Error on EOF unless ENDOFSTREAMOP does something else.")
|
||||
|
||||
(* ;; " NUMBYTES tracks the number of \BINs. ")
|
||||
|
||||
(IF (EQ CHAR NSCHARSETSHIFT)
|
||||
THEN (* ;
|
||||
"Shifting character sets, toss CHAR")
|
||||
(SETQ CSET (\BIN STREAM))
|
||||
(IF (NEQ NSCHARSETSHIFT CSET)
|
||||
THEN (* ;
|
||||
"Shift to new runcode CSET: SH CS CH")
|
||||
(SETQ CHAR (\BIN STREAM))
|
||||
(SETQ NUMBYTES 3)
|
||||
(freplace (STREAM CHARSET) of STREAM with CSET)
|
||||
ELSEIF (EQ 0 (\BIN STREAM))
|
||||
THEN (* ; "SH SH CSH CS CH where CSH is 0")
|
||||
|
||||
(* ;;
|
||||
"The high-order character set byte must be 0, because we don't support obese characters (24 bit)")
|
||||
|
||||
(SETQ CSET (\BIN STREAM))
|
||||
(SETQ CHAR (\BIN STREAM)) (* ; "To align with below")
|
||||
(SETQ NUMBYTES 5)
|
||||
(freplace (STREAM CHARSET) of STREAM with \NORUNCODE)
|
||||
ELSE (\NSIN.24BITENCODING.ERROR STREAM))
|
||||
|
||||
(* ;; "The stream now knows the new character set, runcoded or not.")
|
||||
|
||||
ELSEIF (EQ CSET \NORUNCODE)
|
||||
THEN (* ; "2-bytes")
|
||||
(SETQ CSET CHAR)
|
||||
(SETQ CHAR (\BIN STREAM))
|
||||
(SETQ NUMBYTES 2)
|
||||
ELSE
|
||||
(* ;; "Runcoded CSET and CHAR")
|
||||
|
||||
(SETQ NUMBYTES 1))
|
||||
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* NUMBYTES))
|
||||
(CL:WHEN CHAR (* ;
|
||||
"Typically NIL if ENDOFSTREAMOP returned NIL at EOF ")
|
||||
(LOGOR (UNFOLD CSET 256)
|
||||
CHAR))])
|
||||
|
||||
(\XCCSPEEKCCODE
|
||||
[LAMBDA (STREAM NOERROR) (* ; "Edited 8-Dec-2023 15:32 by rmk")
|
||||
(* ; "Edited 21-Jun-2021 23:44 by rmk:")
|
||||
|
||||
(* ;;
|
||||
"Modeled on \XCCSINCCODE, but peeks at the last byte in the sequence, leaves the stream unchanged")
|
||||
|
||||
(\DTEST STREAM 'STREAM)
|
||||
(LET ((CSET (ffetch (STREAM CHARSET) of STREAM))
|
||||
(CHAR (\PEEKBIN STREAM NOERROR)))
|
||||
|
||||
(* ;; "Returns a 16 bit character code. Doesn't do EOL conversion--\PEEKCCODE does that. ")
|
||||
|
||||
(* ;; "We don't change the charset in the stream, put the file ptr back the way it was.")
|
||||
|
||||
(CL:WHEN CHAR
|
||||
(IF (EQ CHAR NSCHARSETSHIFT)
|
||||
THEN (\BIN STREAM) (* ; "Read the peeked shifting byte")
|
||||
(SETQ CSET (\BIN STREAM)) (* ; "Consume the char shift byte")
|
||||
(IF (NEQ CSET NSCHARSETSHIFT)
|
||||
THEN
|
||||
(* ;;
|
||||
"Shift to new runcode CSET: SH CS CH. We have to BIN what we peeked, BIN, and peek again")
|
||||
|
||||
(SETQ CHAR (\PEEKBIN STREAM NOERROR))
|
||||
(\BACKFILEPTR STREAM)
|
||||
(\BACKFILEPTR STREAM)
|
||||
ELSEIF (EQ 0 (\BIN STREAM))
|
||||
THEN (* ; "SH SH CSH CS CH where CSH is 0")
|
||||
|
||||
(* ;;
|
||||
"Note: no eof error check on this \BIN -- an eof in the middle of a charset shift is an error")
|
||||
|
||||
(SETQ CSET (\BIN STREAM))
|
||||
(SETQ CHAR (\PEEKBIN STREAM NOERROR))
|
||||
(\BACKFILEPTR STREAM)
|
||||
(\BACKFILEPTR STREAM)
|
||||
(\BACKFILEPTR STREAM)
|
||||
(\BACKFILEPTR STREAM)
|
||||
ELSE (\NSIN.24BITENCODING.ERROR STREAM))
|
||||
ELSEIF (EQ CSET \NORUNCODE)
|
||||
THEN (* ; "2 byte runs, BIN/PEEK/BACK")
|
||||
(SETQ CSET CHAR)
|
||||
(\BIN STREAM)
|
||||
(SETQ CHAR (\PEEKBIN STREAM NOERROR)) (* ; "One BACKFILEPTR seems OK")
|
||||
(\BACKFILEPTR STREAM))
|
||||
|
||||
(* ;; "No need to back up for the runcoded case")
|
||||
|
||||
(CL:WHEN CHAR
|
||||
(LOGOR (UNFOLD CSET 256)
|
||||
CHAR)))])
|
||||
|
||||
(\XCCSOUTCHAR
|
||||
[LAMBDA (STREAM CHARCODE) (* ; "Edited 13-Aug-2021 10:24 by rmk:")
|
||||
|
||||
(* ;; "Closed function for the :XCCS external format, also called when :XCCS is the default")
|
||||
|
||||
(COND
|
||||
((EQ CHARCODE (CHARCODE EOL))
|
||||
(FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
||||
[COND
|
||||
[(NOT (\RUNCODED STREAM)) (* ;
|
||||
"Charset is a constant 0, we put out the high-order byte.")
|
||||
(\BOUT STREAM (\CHARSET (CHARCODE EOL]
|
||||
((EQ (\CHARSET (CHARCODE EOL))
|
||||
(ffetch (STREAM CHARSET) of STREAM)))
|
||||
(T (* ;
|
||||
"We are runcoded, and not in character set 0, have to shift.")
|
||||
(\BOUT STREAM NSCHARSETSHIFT)
|
||||
(\BOUT STREAM (freplace (STREAM CHARSET) of STREAM with (\CHARSET
|
||||
(CHARCODE EOL]
|
||||
|
||||
(* ;; "We are now in the right charset (0) for the first EOL byte. For CRLF, the CR is immediately followed by the LF byte, without the prefix 0 byte even if not runcoded, i.e. the 2 bytes are though of as a composite. The stream is left in CSET0 (the freplace above), read for another shift according to the next shift in a runcoded file.")
|
||||
|
||||
(\BOUTEOL STREAM))
|
||||
(T (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
(IPLUS16 1 DATUM))
|
||||
(COND
|
||||
((NOT (\RUNCODED STREAM))
|
||||
(\BOUT STREAM (\CHARSET CHARCODE))
|
||||
(\BOUT STREAM (\CHAR8CODE CHARCODE)))
|
||||
((EQ (\CHARSET CHARCODE)
|
||||
(ffetch (STREAM CHARSET) of STREAM))
|
||||
(\BOUT STREAM (\CHAR8CODE CHARCODE)))
|
||||
(T (\BOUT STREAM NSCHARSETSHIFT)
|
||||
(\BOUT STREAM (freplace (STREAM CHARSET) of STREAM with (\CHARSET
|
||||
CHARCODE))
|
||||
)
|
||||
(\BOUT STREAM (\CHAR8CODE CHARCODE])
|
||||
|
||||
(\XCCSBACKCCODE
|
||||
[LAMBDA (STREAM COUNTP) (* ; "Edited 8-Dec-2023 15:34 by rmk")
|
||||
(* ; "Edited 19-Jul-2022 17:12 by rmk")
|
||||
(* ; "Edited 13-Aug-2021 14:08 by rmk:")
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(LET ((BYTE (AND (\BACKFILEPTR STREAM)
|
||||
(\PEEKBIN STREAM)))
|
||||
(CSET (fetch (STREAM CHARSET) of STREAM)))
|
||||
(CL:WHEN BYTE
|
||||
|
||||
(* ;; "The immediately preceding byte must be a character byte. If it is a byte in a runcode, then we are done, even if the byte before is part of a shift sequence.")
|
||||
|
||||
(* ;; "But if we are currently in a nonruncoded file, we have to go back one more to get the character set byte.")
|
||||
|
||||
(* ;; "If we can't back up, we are already at the beginning.")
|
||||
|
||||
(IF (EQ \NORUNCODE CSET)
|
||||
THEN (IF (\BACKFILEPTR STREAM)
|
||||
THEN (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -2))
|
||||
(LOGOR (UNFOLD (\PEEKBIN STREAM)
|
||||
256)
|
||||
BYTE)
|
||||
ELSE (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
|
||||
NIL)
|
||||
ELSE (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
|
||||
(LOGOR (UNFOLD CSET 256)
|
||||
BYTE)))])
|
||||
|
||||
(\XCCSFORMATBYTESTREAM
|
||||
[LAMBDA (STREAM BYTESTREAM) (* ; "Edited 26-Mar-2024 11:00 by rmk")
|
||||
(* ; "Edited 19-Mar-2024 16:02 by rmk")
|
||||
(\EXTERNALFORMAT BYTESTREAM (\EXTERNALFORMAT STREAM))
|
||||
|
||||
(* ;; "This stream may be read as a continuation of STREAM (TTYIN, LAFITE?), and we want to make sure that the bytes are encoded properly. So let's assert (and possibly mark) that that's its current situation.")
|
||||
|
||||
(\XCCSCHARSETFN BYTESTREAM (fetch (STREAM CHARSET) of STREAM))
|
||||
BYTESTREAM])
|
||||
|
||||
(\XCCSCHARSETFN
|
||||
[LAMBDA (STREAM CHARSET DONTMARKSTREAM) (* ; "Edited 9-Dec-2023 11:18 by rmk")
|
||||
|
||||
(* ;; "This differs from \GENERIC.CHARSET in that it actually writes the shifting bytes into an output stream, unless DONTMARKSTREAM. It will do write the shifts, even if it just replicates the situation that is already there (presumably CHARSET = the old CHARSET). The client should test and avoid calling if useless shifts are not desired.")
|
||||
|
||||
(LET [(CSET (ffetch (STREAM CHARSET) of (\DTEST STREAM 'STREAM]
|
||||
(CL:WHEN CHARSET
|
||||
(CL:WHEN (EQ CHARSET T)
|
||||
(SETQ CHARSET \NORUNCODE))
|
||||
(CL:UNLESS (EQ CHARSET CSET)
|
||||
(freplace (STREAM CHARSET) of STREAM with CHARSET)
|
||||
(CL:UNLESS DONTMARKSTREAM
|
||||
(CL:WHEN (\IOMODEP STREAM 'OUTPUT T)
|
||||
(\BOUT STREAM NSCHARSETSHIFT)
|
||||
(if (EQ CHARSET \NORUNCODE)
|
||||
then (\BOUT STREAM \NORUNCODE)
|
||||
(\BOUT STREAM 0)
|
||||
else (\BOUT STREAM CHARSET))))))
|
||||
CSET])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\CREATE.XCCS.EXTERNALFORMAT
|
||||
[LAMBDA (NAME EOL) (* ; "Edited 7-Dec-2023 23:03 by rmk")
|
||||
(* ; "Edited 30-Jun-2022 18:08 by rmk")
|
||||
(* ; "Edited 10-Sep-2021 19:49 by rmk:")
|
||||
|
||||
(* ;;; "Create the :XCCS external format. Stream's EOL overrides the (vacuous) default here")
|
||||
|
||||
(MAKE-EXTERNALFORMAT (OR NAME :XCCS)
|
||||
(FUNCTION \XCCSINCCODE)
|
||||
(FUNCTION \XCCSPEEKCCODE)
|
||||
(FUNCTION \XCCSBACKCCODE)
|
||||
(FUNCTION \XCCSOUTCHAR)
|
||||
(FUNCTION \XCCSFORMATBYTESTREAM)
|
||||
(OR EOL 'LF)
|
||||
T NIL NIL (FUNCTION \XCCSCHARSETFN])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\NSIN.24BITENCODING.ERROR
|
||||
[LAMBDA (STREAM) (* bvm%: "12-Mar-86 15:35")
|
||||
(DECLARE (USEDFREE *SIGNAL-24BIT-NSENCODING-ERROR*))
|
||||
|
||||
(* ;;; "Called if we see the sequence shift,shift on STREAM -- means shift to 24-bit character set, which we don't support. Usually this just means we're erroneously reading a binary file as text. If this function returns, its value is taken as a character set to shift to")
|
||||
|
||||
(COND
|
||||
(*SIGNAL-24BIT-NSENCODING-ERROR* (* ;
|
||||
"Only cause error if user/reader cares")
|
||||
(ERROR "24-bit NS encoding not supported" STREAM)))
|
||||
(* ; "Return charset zero")
|
||||
0])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(KANJICHARSETP
|
||||
[LAMBDA (CHARSET) (* ; "Edited 13-Jun-2025 16:33 by rmk")
|
||||
|
||||
(* ;; "Returns CHARSET if it is a charset with MCCS Kanji characters")
|
||||
|
||||
(AND (<= 48 CHARSET 118)
|
||||
CHARSET])
|
||||
|
||||
(CHINESECHARSETP
|
||||
[LAMBDA (CHARSET) (* ; "Edited 18-Jun-2025 23:09 by rmk")
|
||||
(* ; "Edited 13-Jun-2025 16:33 by rmk")
|
||||
|
||||
(* ;; "Returns CHARSET if it is a charset with MCCS Chinese characters")
|
||||
|
||||
(AND (<= 161 CHARSET 212)
|
||||
CHARSET])
|
||||
)
|
||||
|
||||
(RPAQ? *SIGNAL-24BIT-NSENCODING-ERROR* )
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ \NORUNCODE 255)
|
||||
|
||||
(RPAQQ NSCHARSETSHIFT 255)
|
||||
|
||||
|
||||
(CONSTANTS (\NORUNCODE 255)
|
||||
(NSCHARSETSHIFT 255))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \RUNCODED MACRO (OPENLAMBDA (STREAM)
|
||||
|
||||
(* ;; "returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented")
|
||||
(* ;
|
||||
"note that neq is ok since charsets are known to be SMALLP's")
|
||||
(NEQ (fetch CHARSET of STREAM)
|
||||
\NORUNCODE)))
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(\CREATE.XCCS.EXTERNALFORMAT)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (997 12253 (\XCCSINCCODE 1007 . 3986) (\XCCSPEEKCCODE 3988 . 6657) (\XCCSOUTCHAR 6659 .
|
||||
8879) (\XCCSBACKCCODE 8881 . 10425) (\XCCSFORMATBYTESTREAM 10427 . 11048) (\XCCSCHARSETFN 11050 .
|
||||
12251)) (12254 13027 (\CREATE.XCCS.EXTERNALFORMAT 12264 . 13025)) (13028 13859 (
|
||||
\NSIN.24BITENCODING.ERROR 13038 . 13857)) (13860 14500 (KANJICHARSETP 13870 . 14126) (CHINESECHARSETP
|
||||
14128 . 14498)))))
|
||||
STOP
|
||||
Binary file not shown.
Reference in New Issue
Block a user