github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-02-27 01:19:42 +00:00
Code Issues Projects Releases Wiki Activity

MCCS coding for UNIX-GETENV, fix MTOUTF8STRING (#2474)

Browse Source 
* MCCS translations for strings passed to/from UNIX-GETENV and other system interfaces.
* INTERPRET.REM.CM assumes system external format is UTF-8.  ISO8859/1 external format is defined in MCCS as a dummy for UTF-8 until UNICODE is loaded
* Add string translation interface to EXTERNALFORMAT datatype, 
* Set the external format of the default reader environment to *DEFAULT-EXTERNALFORMAT* = :MCCS
* Add external format :THROUGH16 for 16 bit codes, used by linebuffer
This commit is contained in:
rmkaplan
2026-02-16 12:06:09 -08:00
committed by GitHub
parent 075ca1a9f1
commit cc0a819cd5
36 changed files with 2246 additions and 1490 deletions
Download Patch File Download Diff File Expand all files Collapse all files

279
greetfiles/APPS-INIT
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Nov-2025 12:30:08" {DSK}<Users>larry>il>MEDLEY>GREETFILES>APPS-INIT.;2 23361
(FILECREATED " 1-Feb-2026 13:41:02" {WMEDLEY}<greetfiles>APPS-INIT.;11 22926
:EDIT-BY "lmm"
:EDIT-BY rmk
:CHANGES-TO (FNS Apps.CreateButtons)
:CHANGES-TO (FNS XCL-USER::EXEC¬INTERLISP)
:PREVIOUS-DATE "25-Feb-2024 13:56:23" {DSK}<Users>larry>il>MEDLEY>GREETFILES>APPS-INIT.;1)
:PREVIOUS-DATE " 1-Feb-2026 07:58:14" {WMEDLEY}<greetfiles>APPS-INIT.;9)
(PRETTYCOMPRINT APPS-INITCOMS)
@@ -19,7 +19,7 @@
(Apps.RoomsActivated NIL))
(FNS Apps.InitNotecards Apps.SetUpNOTECARDSDIRECTORIES Apps.DoInit Apps.CreateButtons
Apps.CreateLabel Apps.ActivateCLOS Apps.ActivateRooms Apps.ShowDoc
XCL-USER::EXEC_INTERLISP Apps.AroundExitFn)
XCL-USER::EXEC¬INTERLISP Apps.AroundExitFn)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (Apps.DoInit)))
(DECLARE%: FIRST DONTEVAL@LOAD DOCOPY (P (BKSYSBUF " "])
@@ -35,52 +35,53 @@
(RPAQ? Apps.RoomsActivated NIL)
(DEFINEQ
(Apps.InitNotecards
(Apps.InitNotecards
[LAMBDA (DoNotRefreshButtons)
(DECLARE (GLOBALVARS BackgroundMenuCommands BackgroundMenu))
(* ; "Edited 19-Jan-2023 11:57 by FGH")
(* ; "Edited 7-Dec-2022 11:14 by FGH")
(* ; "Edited 12-Nov-2022 14:41 by FGH")
(* ; "Edited 11-Sep-2022 01:09 by fgh")
(* ; "Edited 7-Feb-2022 20:22 by tp7")
(DECLARE (GLOBALVARS BackgroundMenuCommands BackgroundMenu))
(* ; "Edited 1-Feb-2026 00:00 by rmk")
(* ; "Edited 19-Jan-2023 11:57 by FGH")
(* ; "Edited 7-Dec-2022 11:14 by FGH")
(* ; "Edited 12-Nov-2022 14:41 by FGH")
(* ; "Edited 11-Sep-2022 01:09 by fgh")
(* ; "Edited 7-Feb-2022 20:22 by tp7")
(LET* [[SRCDIR (OR (UNIX-GETENV 'NOTEFILESSRC)
(AND (UNIX-GETENV 'NC_INSTALLDIR)
(CONCAT (UNIX-GETENV 'NC_INSTALLDIR)
(AND (UNIX-GETENV 'NC¬INSTALLDIR)
(CONCAT (UNIX-GETENV 'NC¬INSTALLDIR)
"/notefiles"))
(LET ((SUBDIR "notecards/notefiles"))
(for DIR in (LIST (CONCAT (MEDLEYDIR)
(for DIR in (LIST (CONCAT (MEDLEYDIR)
SUBDIR)
(CONCAT (MEDLEYDIR)
"../" SUBDIR)
(CONCAT (MEDLEYDIR)
"../../" SUBDIR)) thereis (DIRECTORYNAME DIR]
"../../" SUBDIR)) thereis (DIRECTORYNAME DIR]
(DESTDIR (OR (UNIX-GETENV 'NOTEFILESDIR)
(AND (UNIX-GETENV 'MEDLEY_USERDIR)
(CONCAT (UNIX-GETENV 'MEDLEY_USERDIR)
(AND (UNIX-GETENV 'MEDLEY¬USERDIR)
(CONCAT (UNIX-GETENV 'MEDLEY¬USERDIR)
"/notefiles"))
(CONCAT LOGINDIR "notefiles"]
[if (AND (NOT (DIRECTORYNAME DESTDIR))
[if (AND (NOT (DIRECTORYNAME DESTDIR))
(DIRECTORYNAME SRCDIR))
then (for NF in (DIRECTORY (CONCAT SRCDIR "/*"))
do (COPYFILE NF (PACKFILENAME 'HOST "DSK" 'DIRECTORY DESTDIR 'NAME
then (for NF in (DIRECTORY (CONCAT SRCDIR "/*"))
do (COPYFILE NF (PACKFILENAME 'HOST "DSK" 'DIRECTORY DESTDIR 'NAME
(FILENAMEFIELD NF 'NAME)
'EXTENSION
(FILENAMEFIELD NF 'EXTENSION)
'VERSION
(FILENAMEFIELD NF 'VERSION]
(LET* ((PW-REGION (WINDOWPROP PROMPTWINDOW 'REGION))
(LEFT (IPLUS (fetch (REGION RIGHT) of PW-REGION)
(LEFT (IPLUS (fetch (REGION RIGHT) of PW-REGION)
20))
(BOTTOM (fetch (REGION BOTTOM) of PW-REGION)))
(NC.BringUpNoteCardsIcon (create POSITION
(BOTTOM (fetch (REGION BOTTOM) of PW-REGION)))
(NC.BringUpNoteCardsIcon (create POSITION
XCOORD _ LEFT
YCOORD _ BOTTOM)))
(NC.FileBrowserMenu NC.NoteCardsIconWindow (PACKFILENAME 'HOST "DSK" 'DIRECTORY DESTDIR
'NAME "*" 'EXTENSION "notefile")
(CREATEREGION 50 (IDIFFERENCE SCREENHEIGHT 700)
550 220))
(if (NULL (SASSOC 'NoteCards BackgroundMenuCommands))
then (PROGN [SETQ BackgroundMenuCommands (APPEND BackgroundMenuCommands
(if (NULL (SASSOC 'NoteCards BackgroundMenuCommands))
then (PROGN [SETQ BackgroundMenuCommands (APPEND BackgroundMenuCommands
(LIST '(NoteCards (
NC.BringUpNoteCardsIcon
)
@@ -89,59 +90,61 @@
]
(SETQ BackgroundMenu NIL)))
(SETQ Apps.NotecardsActivated T)
(if (NOT DoNotRefreshButtons)
then (Apps.CreateButtons])
(if (NOT DoNotRefreshButtons)
then (Apps.CreateButtons])
(Apps.SetUpNOTECARDSDIRECTORIES
(Apps.SetUpNOTECARDSDIRECTORIES
[LAMBDA NIL
(* ;; "Find the location of the Notecards directory and call NC.SetUpNOTECARDSDIRECTORIES.")
(* ;; "Find the location of the Notecards directory and call NC.SetUpNOTECARDSDIRECTORIES.")
(* ;; " This is needed to make sure that lazy loading of Notecard types works.")
(* ;; " This is needed to make sure that lazy loading of Notecard types works.")
(LET* [(LOC1 (CONCAT MEDLEYDIR "notecards>"))
(LOC2 (CONCAT MEDLEYDIR "..>notecards>"))
(LOC3 (CONCAT MEDLEYDIR "..>..>notecards>"))
(NCDIR (for LOC in (LIST LOC1 LOC2 LOC3) thereis (OR (INFILEP (CONCAT LOC
(NCDIR (for LOC in (LIST LOC1 LOC2 LOC3) thereis (OR (INFILEP (CONCAT LOC
"system>NOTECARDS"))
(INFILEP (CONCAT LOC
"system>NOTECARDS.LCOM"
]
(if NCDIR
then [SETQ NCDIR (OR (INFILEP (CONCAT NCDIR "system>NOTECARDS"))
(if NCDIR
then [SETQ NCDIR (OR (INFILEP (CONCAT NCDIR "system>NOTECARDS"))
(INFILEP (CONCAT NCDIR "system>NOTECARDS.LCOM"]
(SETQ NCDIR (SUBSTRING NCDIR 1 (IDIFFERENCE (STRPOS "system>NOTECARDS" NCDIR)
1)))
(NC.SetUpNOTECARDSDIRECTORIES NCDIR)
T
else (PRIN1 "Warning: Notecards directory could not be found." T)
else (PRIN1 "Warning: Notecards directory could not be found." T)
(PRIN1 "Hence, NOTECARDSDIRECTORIES is probably not set correctly" T)
(PRIN1 "and Notecards will not work properly." T)
NIL])
(Apps.DoInit
(Apps.DoInit
[LAMBDA NIL
(* ;; "Edited 19-Jan-2023 12:43 by FGH")
(* ;; "Edited 31-Jan-2026 23:57 by rmk")
(* ;; "Edited 17-Jan-2023 23:23 by FGH")
(* ;; "Edited 19-Jan-2023 12:43 by FGH")
(* ;; "Edited 7-Dec-2022 11:14 by FGH")
(* ;; "Edited 17-Jan-2023 23:23 by FGH")
(* ;; "Edited 12-Nov-2022 13:57 by FGH")
(* ;; "Edited 7-Dec-2022 11:14 by FGH")
(* ;; "Edited 12-Oct-2022 20:23 by fgh")
(* ;; "Edited 12-Nov-2022 13:57 by FGH")
(* ;; "Edited 6-Sep-2022 17:22 by fgh")
(* ;; "Edited 12-Oct-2022 20:23 by fgh")
(* ;; "Edited 4-Sep-2022 16:44 by larry")
(* ;; "Edited 6-Sep-2022 17:22 by fgh")
(* ;; "Edited 18-Mar-2022 18:53 by fgh")
(* ;; "Edited 4-Sep-2022 16:44 by larry")
(* ;; "Edited 17-Dec-2021 22:05 by fgh")
(* ;; "Edited 18-Mar-2022 18:53 by fgh")
(* ;; "Edited 17-Dec-2021 22:05 by fgh")
(PROGN
(* ;; " Adjust windows so that the exec window and the prompt window don't overlap")
(* ;; " Adjust windows so that the exec window and the prompt window don't overlap")
[MAPC (OPENWINDOWS)
(FUNCTION (LAMBDA (W)
@@ -152,90 +155,92 @@
(IDIFFERENCE SCREENHEIGHT 18)))
((STREQUAL (WINDOWPROP W 'TITLE)
"Prompt Window")
(PROGN (MOVEW W (create POSITION
(PROGN (MOVEW W (create POSITION
XCOORD _ 50
YCOORD _ (IDIFFERENCE SCREENHEIGHT 120)))
(CLEARW W)))
((STREQUAL (WINDOWPROP W 'TITLE)
"Exec (XCL)")
(PROGN (WINDOWPROP W 'TITLE "Exec (INTERLISP)")
(MOVEW W (create POSITION
(MOVEW W (create POSITION
XCOORD _ 50
YCOORD _ (IDIFFERENCE SCREENHEIGHT 460]
(* ;; " Set up INITIALSLST based on information passed in from the Linux environment")
(* ;; " Set up INITIALSLST based on information passed in from the Linux environment")
[SETQ INITIALSLST (LIST (LIST USERNAME (UNIX-GETENV 'MEDLEY_FIRSTNAME)
(UNIX-GETENV 'MEDLEY_INITIALS]
[SETQ INITIALSLST (LIST (LIST USERNAME (UNIX-GETENV 'MEDLEY¬FIRSTNAME)
(UNIX-GETENV 'MEDLEY¬INITIALS]
(LOAD '{DSK}/usr/local/interlisp/medley/lispusers/HELPSYS.LCOM T)
(* ;; "change to interlisp exec if required")
(* ;; "change to interlisp exec if required")
(COND
((OR (STRING-EQUAL (UNIX-GETENV 'MEDLEY_EXEC)
((OR (STRING-EQUAL (UNIX-GETENV 'MEDLEY¬EXEC)
"inter")
(STRING-EQUAL (UNIX-GETENV 'NCO)
"true"))
(BKSYSBUF "(EXEC_INTERLISP)")))
(BKSYSBUF "(EXEC¬INTERLISP)")))
(* ;; "Always Activate CLOS")
(* ;; "Always Activate CLOS")
(Apps.ActivateCLOS)
(Apps.ActivateCLOS)
(* ;; " activate Notecards if requested")
(* ;; " activate Notecards if requested")
(COND
((STRING-EQUAL (UNIX-GETENV 'RUN_NOTECARDS)
((STRING-EQUAL (UNIX-GETENV 'RUN¬NOTECARDS)
"true")
(Apps.InitNotecards T)))
(Apps.InitNotecards T)))
(* ;; " activate Rooms if requested")
(* ;; " activate Rooms if requested")
(COND
((STRING-EQUAL (UNIX-GETENV 'RUN_ROOMS)
((STRING-EQUAL (UNIX-GETENV 'RUN¬ROOMS)
"true")
(Apps.ActivateRooms T)))
(Apps.ActivateRooms T)))
(* ;; " create the Documentation and ROOMS, Notecards Activation Buttons, if needed")
(* ;; " create the Documentation and ROOMS, Notecards Activation Buttons, if needed")
(Apps.CreateButtons T)
(Apps.CreateButtons T)
(* ;; " Make sure Notecards doesn't try to load its HASH file in NC.PostGreet")
(* ;; " Make sure Notecards doesn't try to load its HASH file in NC.PostGreet")
(SETTOPVAL '\NC.SourceAccessFlg NIL)
(* ;; "Setup NOTECARDSDIRECTORIES.")
(* ;; "Setup NOTECARDSDIRECTORIES.")
(Apps.SetUpNOTECARDSDIRECTORIES)
(Apps.SetUpNOTECARDSDIRECTORIES)
(* ;; "Add AROUNDEXITFN to ensure NOTECARDSDIRECTORIES get reset after LOGOUT, etc.")
(* ;; "Add AROUNDEXITFN to ensure NOTECARDSDIRECTORIES get reset after LOGOUT, etc.")
(SETQ AROUNDEXITFNS (LSUBST '(MEDLEY-INIT-VARS Apps.AroundExitFn)
'MEDLEY-INIT-VARS AROUNDEXITFNS])
(Apps.CreateButtons
[LAMBDA (DoDocsToo) (* ; "Edited 26-Nov-2025 12:29 by lmm")
(* ; "Edited 13-Dec-2022 12:51 by frank")
(* ; "Edited 7-Dec-2022 11:28 by FGH")
(* ; "Edited 5-Dec-2022 17:31 by FGH")
(* ; "Edited 12-Nov-2022 14:52 by FGH")
(Apps.CreateButtons
[LAMBDA (DoDocsToo) (* ; "Edited 31-Jan-2026 23:59 by rmk")
(* ; "Edited 26-Nov-2025 12:29 by lmm")
(* ; "Edited 13-Dec-2022 12:51 by frank")
(* ; "Edited 7-Dec-2022 11:28 by FGH")
(* ; "Edited 5-Dec-2022 17:31 by FGH")
(* ; "Edited 12-Nov-2022 14:52 by FGH")
(* ;; " Create buttons for Documentation and to activate Rooms, Notecards ")
(* ;; " Create buttons for Documentation and to activate Rooms, Notecards ")
(* ;; "Note: due to bug in DELETE-BUTTON need to create Doc buttons last. This will make sure that the NoteCards/Rooms buttons get properl deleted when they are activated. But the Doc buttons will not necessariy get deleted properly (but then there is never a need for them to be deleted).")
(* ;; "Note: due to bug in DELETE-BUTTON need to create Doc buttons last. This will make sure that the NoteCards/Rooms buttons get properl deleted when they are activated. But the Doc buttons will not necessariy get deleted properly (but then there is never a need for them to be deleted).")
(LET* ((FEATURES (LIST (LIST Apps.NotecardsActivated '(Apps.InitNotecards)
(LET* ((FEATURES (LIST (LIST Apps.NotecardsActivated '(Apps.InitNotecards)
"NOTECARDS")
(LIST Apps.RoomsActivated '(Apps.ActivateRooms)
(LIST Apps.RoomsActivated '(Apps.ActivateRooms)
"ROOMS")))
(FEATURES-LABELS (for FEATURE in FEATURES collect (CADDR FEATURE)))
(FEATURES-LABELS (for FEATURE in FEATURES collect (CADDR FEATURE)))
(DOCS (LIST (LIST "https://interlisp.org/docs/medley/orientation/" "BASICS")
(LIST "https://primer.interlisp.org/" "PRIMER")
(LIST "https://interlisp.org/documentation/IRM.pdf" "MANUAL")
(LIST "https://interlisp.org/documentation/notecards_user_guide_v1.2.pdf"
(LIST "https://interlisp.org/documentation/notecards¬user-guide¬v1.2.pdf"
"NOTECARDS")
(LIST "https://interlisp.org/documentation/ROOMSTECHDESC.pdf" "ROOMS")))
(DOCS-LABELS (for DOC in DOCS collect (CADR DOC)))
(DOCS-LABELS (for DOC in DOCS collect (CADR DOC)))
(RIGHTMARGINISH 140)
(SECTION1YPOS 225)
(YPOSDELTA 55)
@@ -249,31 +254,31 @@
(IWS NIL)
(BUTTONS NIL))
(* ;; "First remove/re-create feature buttons")
(* ;; "First remove/re-create feature buttons")
(for W in (OPENWINDOWS) when (MEMBER (WINDOWPROP W 'ICONLABEL)
(LIST "ACTIVATE" "FEATURES")) do (CLOSEW W))
(for B in *ALL-BUTTONS* when (AND (EQ (WINDOWPROP B 'Apps.BUTTON)
(for W in (OPENWINDOWS) when (MEMBER (WINDOWPROP W 'ICONLABEL)
(LIST "ACTIVATE" "FEATURES")) do (CLOSEW W))
(for B in *ALL-BUTTONS* when (AND (EQ (WINDOWPROP B 'Apps.BUTTON)
'FEATURE)
(MEMBER (BUTTON-LABEL B)
FEATURES-LABELS)) do (DELETE-BUTTON B))
[if FEATURES-REQUIREDP
then [SETQ IWS (LIST (Apps.CreateLabel "ACTIVATE" (IDIFFERENCE SCREENWIDTH
FEATURES-LABELS)) do (DELETE-BUTTON B))
[if FEATURES-REQUIREDP
then [SETQ IWS (LIST (Apps.CreateLabel "ACTIVATE" (IDIFFERENCE SCREENWIDTH
(IDIFFERENCE RIGHTMARGINISH 50
))
(IDIFFERENCE SCREENHEIGHT (IDIFFERENCE SECTION2YPOS 20)))
(Apps.CreateLabel "FEATURES" (IDIFFERENCE SCREENWIDTH
(Apps.CreateLabel "FEATURES" (IDIFFERENCE SCREENWIDTH
(IDIFFERENCE RIGHTMARGINISH 50
))
(IDIFFERENCE SCREENHEIGHT SECTION2YPOS]
(SETQ BUTTONS (for FEATURE in FEATURES
collect (OR (CAR FEATURE)
(SETQ BUTTONS (for FEATURE in FEATURES
collect (OR (CAR FEATURE)
(LET (B)
(SETQ BUTTONY-FEATURES (IPLUS BUTTONY-FEATURES
YPOSDELTA))
[SETQ B (CREATE-BUTTON (CADR FEATURE)
(CADDR FEATURE)
(create POSITION
(create POSITION
XCOORD _ (IDIFFERENCE
SCREENWIDTH
RIGHTMARGINISH)
@@ -284,30 +289,30 @@
(WINDOWPROP B 'Apps.BUTTON 'FEATURE)
B]
(* ;; "Then if needed, remove/recreate documentation buttons")
(* ;; "Then if needed, remove/recreate documentation buttons")
(if DoDocsToo
then (for W in (OPENWINDOWS) when (MEMBER (WINDOWPROP W 'ICONLABEL)
(if DoDocsToo
then (for W in (OPENWINDOWS) when (MEMBER (WINDOWPROP W 'ICONLABEL)
(LIST "DOCUMENTATION"))
do (CLOSEW W))
(for B in *ALL-BUTTONS* when (AND (EQ (WINDOWPROP B 'Apps.BUTTON)
do (CLOSEW W))
(for B in *ALL-BUTTONS* when (AND (EQ (WINDOWPROP B 'Apps.BUTTON)
'DOC)
(MEMBER (BUTTON-LABEL B)
DOCS-LABELS)) do (DELETE-BUTTON B))
(SETQ IWS (CONS (Apps.CreateLabel "DOCUMENTATION" (IDIFFERENCE SCREENWIDTH
DOCS-LABELS)) do (DELETE-BUTTON B))
(SETQ IWS (CONS (Apps.CreateLabel "DOCUMENTATION" (IDIFFERENCE SCREENWIDTH
(IDIFFERENCE
RIGHTMARGINISH 50)
)
(IDIFFERENCE SCREENHEIGHT SECTION1YPOS))
IWS))
(SETQ BUTTONS (APPEND (for DOC in DOCS
collect (LET (B)
(SETQ BUTTONS (APPEND (for DOC in DOCS
collect (LET (B)
(SETQ BUTTONY-DOCS (IPLUS BUTTONY-DOCS
YPOSDELTA))
[SETQ B (CREATE-BUTTON (LIST 'Apps.ShowDoc
(CAR DOC))
(CADR DOC)
(create POSITION
(create POSITION
XCOORD _
(IDIFFERENCE
SCREENWIDTH
@@ -319,30 +324,30 @@
(WINDOWPROP B 'Apps.BUTTON 'DOC)
B))
BUTTONS)))
[for B in BUTTONS do (COND
[for B in BUTTONS do (COND
((WINDOWP B)
(WINDOWPROP B 'RIGHTBUTTONFN 'NILL)
(WINDOWPROP B 'BUTTONEVENTFN (FUNCTION (LAMBDA (BUTTON)
(if (LASTMOUSESTATE
(if (LASTMOUSESTATE
(ONLY LEFT))
then (EXECUTE-BUTTON
then (EXECUTE-BUTTON
BUTTON]
[for IW in IWS do (COND
[for IW in IWS do (COND
((WINDOWP IW)
(WINDOWPROP IW 'RIGHTBUTTONFN 'NILL]
(for B in BUTTONS when (WINDOWP B) collect B])
(for B in BUTTONS when (WINDOWP B) collect B])
(Apps.CreateLabel
[LAMBDA (Text CenterX BottomY) (* ; "Edited 5-Dec-2022 16:49 by FGH")
(Apps.CreateLabel
[LAMBDA (Text CenterX BottomY) (* ; "Edited 5-Dec-2022 16:49 by FGH")
(LET* ((DS (DSPCREATE))
(FONT (DSPFONT '(HELVETICA 18 BOLD)
DS))
(SR (STRINGREGION Text DS))
(BMW (fetch (REGION WIDTH) of SR))
(BMH (IPLUS (fetch (REGION HEIGHT) of SR)
(fetch (REGION BOTTOM) of SR)))
(BMW (fetch (REGION WIDTH) of SR))
(BMH (IPLUS (fetch (REGION HEIGHT) of SR)
(fetch (REGION BOTTOM) of SR)))
(BM (BITMAPCREATE BMW BMH))
(POS (create POSITION
(POS (create POSITION
XCOORD _ (IDIFFERENCE CenterX (IQUOTIENT BMW 2))
YCOORD _ BottomY))
IW)
@@ -352,12 +357,12 @@
(WINDOWPROP IW 'ICONLABEL Text)
IW])
(Apps.ActivateCLOS
(Apps.ActivateCLOS
[LAMBDA NIL
(DECLARE (GLOBALVARS BackgroundMenuCommands BackgroundMenu))
(* ; "Edited 12-Nov-2022 14:41 by FGH")
(if (NULL (SASSOC "CLOS Browse Class" BackgroundMenuCommands))
then (PROGN [SETQ BackgroundMenuCommands
(DECLARE (GLOBALVARS BackgroundMenuCommands BackgroundMenu))
(* ; "Edited 12-Nov-2022 14:41 by FGH")
(if (NULL (SASSOC "CLOS Browse Class" BackgroundMenuCommands))
then (PROGN [SETQ BackgroundMenuCommands
(APPEND BackgroundMenuCommands
(LIST '("CLOS Browse Class" (CLOS-BROWSER::BROWSE-CLASS)
"Bring up a class browser."
@@ -372,27 +377,27 @@
]
(SETQ BackgroundMenu NIL])
(Apps.ActivateRooms
(Apps.ActivateRooms
[LAMBDA (DoNotRefreshButtons)
(DECLARE (GLOBALVARS BackgroundMenuCommands ROOMS:*SUITE-DIRECTORIES*))
(* ; "Edited 7-Dec-2022 11:13 by FGH")
(* ; "Edited 12-Nov-2022 14:56 by FGH")
(if (NULL (SASSOC "Rooms" BackgroundMenuCommands))
then (ROOMS:RESET))
(SETQ ROOMS:*SUITE-DIRECTORIES* (CONS (CONCAT (UNIX-GETENV 'MEDLE_USERDIR)
(DECLARE (GLOBALVARS BackgroundMenuCommands ROOMS:*SUITE-DIRECTORIES*))
(* ; "Edited 7-Dec-2022 11:13 by FGH")
(* ; "Edited 12-Nov-2022 14:56 by FGH")
(if (NULL (SASSOC "Rooms" BackgroundMenuCommands))
then (ROOMS:RESET))
(SETQ ROOMS:*SUITE-DIRECTORIES* (CONS (CONCAT (UNIX-GETENV 'MEDLEY¬USERDIR)
"/suites")
ROOMS:*SUITE-DIRECTORIES*))
(SETQ Apps.RoomsActivated T)
(PROMPTPRINT "
ROOMS functionality is now available via the Background Menu")
(if (NOT DoNotRefreshButtons)
then (Apps.CreateButtons])
(if (NOT DoNotRefreshButtons)
then (Apps.CreateButtons])
(Apps.ShowDoc
[LAMBDA (URL) (* ; "Edited 18-Jan-2023 20:26 by FGH")
(Apps.ShowDoc
[LAMBDA (URL) (* ; "Edited 18-Jan-2023 20:26 by FGH")
(ShellBrowse URL])
(XCL-USER::EXEC_INTERLISP
(XCL-USER::EXEC¬INTERLISP
[LAMBDA NIL (* ; "Edited 18-Mar-2022 18:53 by fgh")
(PROGN [MAPC (OPENWINDOWS)
(FUNCTION (LAMBDA (W)
@@ -406,10 +411,10 @@
(XCL:SET-DEFAULT-EXEC-TYPE 'INTERLISP)
(XCL:SET-EXEC-TYPE 'INTERLISP])
(Apps.AroundExitFn
(Apps.AroundExitFn
[LAMBDA (EVENT)
(if (MEMB EVENT '(AFTERLOGOUT AFTERSYSOUT AFTERSAVEVM))
then (Apps.SetUpNOTECARDSDIRECTORIES])
(if (MEMB EVENT '(AFTERLOGOUT AFTERSYSOUT AFTERSAVEVM))
then (Apps.SetUpNOTECARDSDIRECTORIES])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
@@ -420,8 +425,8 @@
(BKSYSBUF " ")
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1184 23227 (Apps.InitNotecards 1194 . 5056) (Apps.SetUpNOTECARDSDIRECTORIES 5058 . 6613
) (Apps.DoInit 6615 . 10212) (Apps.CreateButtons 10214 . 19123) (Apps.CreateLabel 19125 . 19935) (
Apps.ActivateCLOS 19937 . 21286) (Apps.ActivateRooms 21288 . 22139) (Apps.ShowDoc 22141 . 22290) (
XCL-USER::EXEC_INTERLISP 22292 . 23064) (Apps.AroundExitFn 23066 . 23225)))))
(FILEMAP (NIL (1153 22792 (Apps.InitNotecards 1163 . 5006) (Apps.SetUpNOTECARDSDIRECTORIES 5008 . 6527
) (Apps.DoInit 6529 . 10067) (Apps.CreateButtons 10069 . 18820) (Apps.CreateLabel 18822 . 19592) (
Apps.ActivateCLOS 19594 . 20919) (Apps.ActivateRooms 20921 . 21730) (Apps.ShowDoc 21732 . 21871) (
XCL-USER::EXEC¬INTERLISP 21873 . 22645) (Apps.AroundExitFn 22647 . 22790)))))
STOP

BIN
greetfiles/APPS-INIT.LCOM
View File

Binary file not shown.

16
internal/loadups/LOADUP-APPS
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 9-Mar-2025 20:03:27" {DSK}<home>frank>il>medley>internal>loadups>LOADUP-APPS.;10 3274
(FILECREATED " 1-Feb-2026 13:45:36" {WMEDLEY}<internal>loadups>LOADUP-APPS.;3 3343
:EDIT-BY "frank"
:EDIT-BY rmk
:CHANGES-TO (FNS LOADUP-APPS)
:PREVIOUS-DATE " 9-Mar-2025 19:42:36" {DSK}<home>frank>il>medley>internal>loadups>LOADUP-APPS.;8
)
:PREVIOUS-DATE " 9-Mar-2025 20:03:27" {WMEDLEY}<internal>loadups>LOADUP-APPS.;2)
(PRETTYCOMPRINT LOADUP-APPSCOMS)
@@ -21,7 +20,8 @@
(DEFINEQ
(LOADUP-APPS
[LAMBDA NIL (* ; "Edited 9-Mar-2025 20:02 by frank")
[LAMBDA NIL (* ; "Edited 1-Feb-2026 13:45 by rmk")
(* ; "Edited 9-Mar-2025 20:02 by frank")
(* ; "Edited 2-Jan-2025 20:38 by lmm")
(* ; "Edited 2-Jan-2025 06:30 by larry")
@@ -46,7 +46,7 @@
"/system"))
NOTECARDS))
(Apps.RemoveBackgroundMenuItem 'NoteCards) (* ; "")
(PUTASSOC 'NOTECARDS (LIST (UNIX-GETENV 'NOTECARDS_COMMIT_ID))
(PUTASSOC 'NOTECARDS (LIST (UNIX-GETENV 'NOTECARDS¬COMMIT¬ID))
SYSOUTCOMMITS)
(* ;; "======================")
@@ -78,7 +78,7 @@
(* ;; "")
(PUTASSOC 'MEDLEY (LIST (UNIX-GETENV 'LOADUP_COMMIT_ID))
(PUTASSOC 'MEDLEY (LIST (UNIX-GETENV 'LOADUP¬COMMIT¬ID))
SYSOUTCOMMITS)
(PRINTOUT T "commits-- " SYSOUTCOMMITS T])
@@ -95,5 +95,5 @@
Apps.SBG])
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (656 3251 (LOADUP-APPS 666 . 2579) (Apps.RemoveBackgroundMenuItem 2581 . 3249)))))
(FILEMAP (NIL (616 3320 (LOADUP-APPS 626 . 2648) (Apps.RemoveBackgroundMenuItem 2650 . 3318)))))
STOP

BIN
internal/loadups/LOADUP-APPS.LCOM
View File

Binary file not shown.

15
internal/loadups/LOADUP-FULL
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "28-Dec-2025 12:06:12" {WMEDLEY}<internal>loadups>LOADUP-FULL.;35 5759
(FILECREATED " 5-Feb-2026 10:26:39" {WMEDLEY}<internal>loadups>LOADUP-FULL.;36 5858
:EDIT-BY rmk
:CHANGES-TO (FNS LOADUP-FULL)
:PREVIOUS-DATE "20-Sep-2025 14:18:19" {WMEDLEY}<internal>loadups>LOADUP-FULL.;34)
:PREVIOUS-DATE "28-Dec-2025 12:06:12" {WMEDLEY}<internal>loadups>LOADUP-FULL.;35)
(PRETTYCOMPRINT LOADUP-FULLCOMS)
@@ -47,7 +47,8 @@
(PRINTOUT T "FULL fonts loaded" T])
(LOADUP-FULL
[LAMBDA (DRIBBLEFILE) (* ; "Edited 28-Dec-2025 12:06 by rmk")
[LAMBDA (DRIBBLEFILE) (* ; "Edited 5-Feb-2026 10:26 by rmk")
(* ; "Edited 28-Dec-2025 12:06 by rmk")
(* ; "Edited 1-Sep-2025 11:59 by rmk")
(* ; "Edited 18-Aug-2025 12:09 by rmk")
(* ; "Edited 21-Jun-2025 23:33 by rmk")
@@ -84,9 +85,9 @@
(* ;; "RMK: 2025: PRESS was after CHAT")
(LOADUP '(CHAT INTERPRESS TEDIT HRULE TEDIT-CHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES
GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT ISO8859IO
HELPSYS DINFO CLIPBOARD MODERNIZE WHEELSCROLL PRETTYFILEINDEX WHO-LINE UNIXCOMM
UNIXCHAT UNIXYCD))
GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT HELPSYS
DINFO CLIPBOARD MODERNIZE WHEELSCROLL PRETTYFILEINDEX WHO-LINE UNIXCOMM UNIXCHAT
UNIXYCD))
(COND
((WINDOWP *WHO-LINE*)
(CLOSEW *WHO-LINE*)))
@@ -101,5 +102,5 @@
(FIXMETA)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (456 5721 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5471) (FIXMETA 5473 . 5719)))))
(FILEMAP (NIL (456 5820 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5570) (FIXMETA 5572 . 5818)))))
STOP

BIN
internal/loadups/LOADUP-FULL.LCOM
View File

Binary file not shown.

63
library/UNICODE
View File

@@ -1,14 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "23-Oct-2025 08:31:21" {WMEDLEY}<library>UNICODE.;211 82245
(FILECREATED " 5-Feb-2026 11:07:12" {WMEDLEY}<library>UNICODE.;213 82607
:EDIT-BY rmk
:CHANGES-TO (FNS UTOMCODE UTF8.INCCODEFN UTOMCODE? UTF8.PEEKCCODEFN)
(VARS UNICODECOMS)
(MACROS UNICODE.SMALLP)
:CHANGES-TO (FNS MAKE-UNICODE-FORMATS)
:PREVIOUS-DATE "22-Oct-2025 23:28:51" {WMEDLEY}<library>UNICODE.;210)
:PREVIOUS-DATE "31-Jan-2026 19:24:45" {WMEDLEY}<library>UNICODE.;212)
(PRETTYCOMPRINT UNICODECOMS)
@@ -590,7 +588,8 @@
(DEFINEQ
(MAKE-UNICODE-FORMATS
[LAMBDA (EXTERNALEOL) (* ; "Edited 17-Jan-2025 18:38 by rmk")
[LAMBDA (EXTERNALEOL) (* ; "Edited 5-Feb-2026 11:06 by rmk")
(* ; "Edited 17-Jan-2025 18:38 by rmk")
(* ; "Edited 10-Mar-2024 11:55 by rmk")
(* ; "Edited 8-Dec-2023 15:19 by rmk")
(* ; "Edited 19-Jul-2022 15:36 by rmk")
@@ -604,7 +603,10 @@
(FUNCTION UTF8.PEEKCCODEFN)
(FUNCTION \UTF8.BACKCCODEFN)
(FUNCTION UTF8.OUTCHARFN)
NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL))
NIL EXTERNALEOL NIL (FUNCTION MTOUTF8STRING)
NIL
(FUNCTION NILL)
(FUNCTION UTF8TOMSTRING))
(MAKE-EXTERNALFORMAT :UTF-8-RAW [FUNCTION (LAMBDA (STREAM COUNTP)
(UTF8.INCCODEFN STREAM COUNTP T]
[FUNCTION (LAMBDA (STREAM NOERROR)
@@ -955,7 +957,8 @@
do (RPLCHARCODE MSTRING I (UTOMCODE UCODE)) finally (RETURN MSTRING])
(MTOUTF8STRING
[LAMBDA (MSTRING) (* ; "Edited 9-Sep-2025 07:51 by rmk")
[LAMBDA (MSTRING) (* ; "Edited 31-Jan-2026 19:15 by rmk")
(* ; "Edited 9-Sep-2025 07:51 by rmk")
(* ; "Edited 4-Sep-2025 15:13 by rmk")
(* ; "Edited 2-Sep-2025 11:12 by rmk")
(* ; "Edited 24-Apr-2025 15:37 by rmk")
@@ -968,11 +971,13 @@
(* ;; "The resulting string will not be directly interpretable inside Medley.")
(if (if (STRINGP MSTRING)
then (OR (ffetch (STRINGP FATSTRINGP) of MSTRING)
(thereis C instring MSTRING suchthat (IGEQ C 128)))
then [OR (ffetch (STRINGP FATSTRINGP) of MSTRING)
(thereis C instring MSTRING suchthat (OR (IGEQ C 128)
(NEQ C (MTOUCODE C]
elseif (LITATOM MSTRING)
then (OR (ffetch (LITATOM FATPNAMEP) of MSTRING)
(thereis C inatom MSTRING suchthat (IGEQ C 128)))
then [OR (ffetch (LITATOM FATPNAMEP) of MSTRING)
(thereis C inatom MSTRING suchthat (OR (IGEQ C 128)
(NEQ C (MTOUCODE C]
else T)
then (LET [(USTR (ALLOCSTRING (NUTF8-STRING-BYTES MSTRING]
(for I UCODE MCODE (SINDEX _ 0) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I))
@@ -1483,21 +1488,21 @@
(PUTPROPS UNICODE FILETYPE :TCOMPL)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3488 19026 (UTF8.OUTCHARFN 3498 . 6514) (UTF8.SLUG.OUTCHARFN 6516 . 7180) (
UTF8.INCCODEFN 7182 . 13035) (UTF8.PEEKCCODEFN 13037 . 18044) (\UTF8.BACKCCODEFN 18046 . 19024)) (
19027 23717 (UTF16BE.OUTCHARFN 19037 . 20056) (UTF16BE.INCCODEFN 20058 . 21183) (UTF16BE.PEEKCCODEFN
21185 . 22525) (\UTF16BE.BACKCCODEFN 22527 . 23715)) (23718 28441 (UTF16LE.OUTCHARFN 23728 . 24844) (
UTF16LE.INCCODEFN 24846 . 25971) (UTF16LE.PEEKCCODEFN 25973 . 27249) (\UTF16LE.BACKCCODEFN 27251 .
28439)) (28442 31489 (READBOM 28452 . 30521) (WRITEBOM 30523 . 31487)) (31519 35084 (
MAKE-UNICODE-FORMATS 31529 . 35082)) (35181 39675 (UTF8.BINCODE 35191 . 37879) (\UTF8.FETCHCODE 37881
. 39673)) (39676 45303 (UTF8.VALIDATE 39686 . 42283) (NUTF8-BYTE1-BYTES 42285 . 43022) (
NUTF8-CODE-BYTES 43024 . 44081) (NUTF8-STRING-BYTES 44083 . 44979) (N-MCHARS 44981 . 45301)) (47785
57213 (MTOUCODE 47795 . 48182) (UTOMCODE 48184 . 48710) (MTOUCODE? 48712 . 49745) (UTOMCODE? 49747 .
50916) (MTOUSTRING 50918 . 51503) (UTOMSTRING 51505 . 52090) (MTOUTF8STRING 52092 . 56098) (
UTF8TOMSTRING 56100 . 57211)) (57214 62916 (XTOUCODE 57224 . 57742) (UTOXCODE 57744 . 58252) (
XTOUCODE? 58254 . 59315) (UTOXCODE? 59317 . 60400) (XTOUSTRING 60402 . 61095) (UTOXSTRING 61097 .
61838) (XTOUTF8STRING 61840 . 62914)) (62979 74247 (WRITE-UNICODE-MAPPING 62989 . 66739) (
WRITE-UNICODE-INCLUDED 66741 . 71463) (WRITE-UNICODE-MAPPING-HEADER 71465 . 72713) (
WRITE-UNICODE-MAPPING-FILENAME 72715 . 74245)) (74248 74924 (XCCS-UTF8-AFTER-OPEN 74258 . 74922)) (
77449 79666 (UTF8HEXSTRING 77459 . 79664)) (79693 81735 (SHOWCHARS 79703 . 81733)))))
(FILEMAP (NIL (3379 18917 (UTF8.OUTCHARFN 3389 . 6405) (UTF8.SLUG.OUTCHARFN 6407 . 7071) (
UTF8.INCCODEFN 7073 . 12926) (UTF8.PEEKCCODEFN 12928 . 17935) (\UTF8.BACKCCODEFN 17937 . 18915)) (
18918 23608 (UTF16BE.OUTCHARFN 18928 . 19947) (UTF16BE.INCCODEFN 19949 . 21074) (UTF16BE.PEEKCCODEFN
21076 . 22416) (\UTF16BE.BACKCCODEFN 22418 . 23606)) (23609 28332 (UTF16LE.OUTCHARFN 23619 . 24735) (
UTF16LE.INCCODEFN 24737 . 25862) (UTF16LE.PEEKCCODEFN 25864 . 27140) (\UTF16LE.BACKCCODEFN 27142 .
28330)) (28333 31380 (READBOM 28343 . 30412) (WRITEBOM 30414 . 31378)) (31410 35163 (
MAKE-UNICODE-FORMATS 31420 . 35161)) (35260 39754 (UTF8.BINCODE 35270 . 37958) (\UTF8.FETCHCODE 37960
. 39752)) (39755 45382 (UTF8.VALIDATE 39765 . 42362) (NUTF8-BYTE1-BYTES 42364 . 43101) (
NUTF8-CODE-BYTES 43103 . 44160) (NUTF8-STRING-BYTES 44162 . 45058) (N-MCHARS 45060 . 45380)) (47864
57575 (MTOUCODE 47874 . 48261) (UTOMCODE 48263 . 48789) (MTOUCODE? 48791 . 49824) (UTOMCODE? 49826 .
50995) (MTOUSTRING 50997 . 51582) (UTOMSTRING 51584 . 52169) (MTOUTF8STRING 52171 . 56460) (
UTF8TOMSTRING 56462 . 57573)) (57576 63278 (XTOUCODE 57586 . 58104) (UTOXCODE 58106 . 58614) (
XTOUCODE? 58616 . 59677) (UTOXCODE? 59679 . 60762) (XTOUSTRING 60764 . 61457) (UTOXSTRING 61459 .
62200) (XTOUTF8STRING 62202 . 63276)) (63341 74609 (WRITE-UNICODE-MAPPING 63351 . 67101) (
WRITE-UNICODE-INCLUDED 67103 . 71825) (WRITE-UNICODE-MAPPING-HEADER 71827 . 73075) (
WRITE-UNICODE-MAPPING-FILENAME 73077 . 74607)) (74610 75286 (XCCS-UTF8-AFTER-OPEN 74620 . 75284)) (
77811 80028 (UTF8HEXSTRING 77821 . 80026)) (80055 82097 (SHOWCHARS 80065 . 82095)))))
STOP

BIN
library/UNICODE.LCOM
View File

Binary file not shown.

26
library/UNIXCOMM
View File

@@ -1,14 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Sep-2025 12:06:52" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>UNIXCOMM.;14 14825
(FILECREATED " 5-Feb-2026 18:38:23" {WMEDLEY}<library>UNIXCOMM.;15 14717
:EDIT-BY rmk
:CHANGES-TO (FNS FORK-UNIX)
:PREVIOUS-DATE "29-Apr-2025 22:45:47"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>UNIXCOMM.;13)
:PREVIOUS-DATE " 2-Sep-2025 12:06:52" {WMEDLEY}<library>UNIXCOMM.;14)
(PRETTYCOMPRINT UNIXCOMMCOMS)
@@ -74,13 +72,11 @@
else (SUBRCALL UNIX-HANDLECOMM 4])
(FORK-UNIX
[LAMBDA (STR) (* ; "Edited 2-Sep-2025 12:03 by rmk")
[LAMBDA (STR) (* ; "Edited 5-Feb-2026 18:38 by rmk")
(* ; "Edited 2-Sep-2025 12:03 by rmk")
(* ; "Edited 29-Apr-2025 22:45 by rmk")
(* ; "Edited 25-May-88 15:47 by drc:")
(* ;; "MTOUBYTES converts MCCS codes to Unicodes, and then lays out the bytes of the UTF-8 encoding of those characters. ")
(SUBRCALL UNIX-HANDLECOMM 0 (MTOUTF8STRING (\DTEST STR 'ONED-ARRAY])
(SUBRCALL UNIX-HANDLECOMM 0 (MTOSYSSTRING (\DTEST STR 'ONED-ARRAY])
(UNIX-KILL
[LAMBDA (CONN) (* ; "Edited 25-May-88 16:04 by drc:")
@@ -321,10 +317,10 @@
(PUTPROPS UNIXCOMM FILETYPE COMPILE-FILE)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1903 7339 (FORK-SHELL 1913 . 3110) (FORK-UNIX 3112 . 3659) (UNIX-KILL 3661 . 3850) (
UNIX-WRITE 3852 . 4563) (CREATE-SHELL-STREAM 4565 . 5449) (CREATE-PROCESS-STREAM 5451 . 6290) (
UNIXCOMM-AROUNDEXITFN 6292 . 7337)) (7387 12578 (INITIALIZE-SHELL-DEVICE 7397 . 8825) (
UNIX-GET-NEXT-BUFFER 8827 . 11027) (UNIX-BACKFILEPTR 11029 . 11441) (UNIX-STREAM-EOFP 11443 . 11924) (
UNIX-STREAM-OUT 11926 . 12182) (UNIX-STREAM-CLOSE 12184 . 12576)) (12826 14532 (
CREATE-UNIX-SOCKET-STREAM 12836 . 13642) (ACCEPT-UNIX-SOCKET-STREAM 13644 . 14530)))))
(FILEMAP (NIL (1821 7231 (FORK-SHELL 1831 . 3028) (FORK-UNIX 3030 . 3551) (UNIX-KILL 3553 . 3742) (
UNIX-WRITE 3744 . 4455) (CREATE-SHELL-STREAM 4457 . 5341) (CREATE-PROCESS-STREAM 5343 . 6182) (
UNIXCOMM-AROUNDEXITFN 6184 . 7229)) (7279 12470 (INITIALIZE-SHELL-DEVICE 7289 . 8717) (
UNIX-GET-NEXT-BUFFER 8719 . 10919) (UNIX-BACKFILEPTR 10921 . 11333) (UNIX-STREAM-EOFP 11335 . 11816) (
UNIX-STREAM-OUT 11818 . 12074) (UNIX-STREAM-CLOSE 12076 . 12468)) (12718 14424 (
CREATE-UNIX-SOCKET-STREAM 12728 . 13534) (ACCEPT-UNIX-SOCKET-STREAM 13536 . 14422)))))
STOP

BIN
library/UNIXCOMM.DFASL Normal file
View File

Binary file not shown.

19
library/UNIXPRINT
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "25-Jan-2026 11:09:09" {WMEDLEY}<library>UNIXPRINT.;15 11553
(FILECREATED " 5-Feb-2026 18:37:09" {WMEDLEY}<library>UNIXPRINT.;17 11663
:EDIT-BY rmk
:CHANGES-TO (FNS UnixPrint)
:CHANGES-TO (FNS UnixShellQuote)
:PREVIOUS-DATE "18-Jan-2026 08:44:40" {WMEDLEY}<library>UNIXPRINT.;14)
:PREVIOUS-DATE "25-Jan-2026 11:09:09" {WMEDLEY}<library>UNIXPRINT.;15)
(PRETTYCOMPRINT UNIXPRINTCOMS)
@@ -130,7 +130,8 @@
(UnixShellQuote
[LAMBDA (STRING)
(DECLARE (LOCALVARS . T)) (* ; "Edited 18-Jan-2026 08:34 by rmk")
(DECLARE (LOCALVARS . T)) (* ; "Edited 5-Feb-2026 18:37 by rmk")
(* ; "Edited 18-Jan-2026 08:34 by rmk")
(* ; "Edited 19-Apr-89 21:14 by TAL")
(LET* ((X (CHCON STRING))
(CT X)
@@ -155,9 +156,9 @@
(CHARCODE SPACE))
(T C))
(SETQ CT (CDR CT]
(MTOUTF8STRING (COND
(FLG (CONCATCODES X))
(T STRING])
(MTOSYSSTRING (CL:IF FLG
(CONCATCODES X)
STRING)])
(UnixTempFile
[LAMBDA (Prefix DontOpen) (* ; "Edited 28-Apr-93 13:49 by rmk:")
@@ -251,6 +252,6 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1046 10887 (UnixPrint 1056 . 6392) (UnixShellQuote 6394 . 7977) (UnixTempFile 7979 .
9202) (UnixPrintCommand 9204 . 10885)))))
(FILEMAP (NIL (1051 10997 (UnixPrint 1061 . 6397) (UnixShellQuote 6399 . 8087) (UnixTempFile 8089 .
9312) (UnixPrintCommand 9314 . 10995)))))
STOP

BIN
library/UNIXPRINT.DFASL
View File

Binary file not shown.

151
lispusers/CHATSERVER
View File

@@ -1,14 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 7-Sep-88 17:08:57" {ERINYES}<LISPUSERS>MEDLEY>CHATSERVER.;11 47957
changes to%: (FNS CHATSERVEROPENFN)
(FILECREATED " 9-Feb-2026 22:25:32" {WMEDLEY}<lispusers>CHATSERVER.;2 45227
previous date%: "19-May-88 00:37:49" {ERINYES}<LISPUSERS>MEDLEY>CHATSERVER.;10)
:EDIT-BY rmk
:CHANGES-TO (FNS \CREATELINEBUFFER)
:PREVIOUS-DATE " 7-Sep-88 17:08:57" {WMEDLEY}<lispusers>CHATSERVER.;1)
(* "
Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CHATSERVERCOMS)
@@ -40,8 +39,7 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
(COMMANDS "QUIT" "SAY")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA \REMOTE.BIN
CHATSERVEROPENFN])
(LAMA CHATSERVEROPENFN])
(DEFINEQ
(CHATSERVER
@@ -450,34 +448,34 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
(RETURN CHARBUFFER])
(\CREATELINEBUFFER
[LAMBDA (TERMINAL.STREAM) (* ; "Edited 13-Apr-87 22:57 by bvm:")
(* ;;
 "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).")
[LAMBDA (TERMINAL.STREAM) (* ; "Edited 9-Feb-2026 22:21 by rmk")
(* ; "Edited 13-Apr-87 22:57 by bvm:")
(LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((CHARSET T]
(* ;; "This is a copy of \CREATELINEBUFFER on ATERM, except for the source of the EOFMETHOD.")
(* ;;
 "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).")
(LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((:EXTERNAL-FORMAT :THROUGH16]
(DEV (fetch (STREAM DEVICE) of STREAM))
EOFMETHOD)
(replace LINEBUFSTATE of STREAM with READING.LBS)
(replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM
\KEYBOARD.STREAM))
(replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM \KEYBOARD.STREAM))
(replace USERCLOSEABLE of STREAM with NIL)
(replace USERVISIBLE of STREAM with NIL)
(* ;
 "Other linebuffer fields default properly")
(replace USERVISIBLE of STREAM with NIL) (* ;
 "Other linebuffer fields default properly")
[replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM)
(CL:FUNCALL \RefillBufferFn]
(if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP)
of (fetch (STREAM DEVICE)
TERMINAL.STREAM)))
'NILL))
(CL:FUNCALL \RefillBufferFn]
(if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of (fetch (STREAM DEVICE)
TERMINAL.STREAM)
))
'NILL))
then
(* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.")
(* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.")
(replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE
'FDEV DEV)))
(* ;
 "Copy the basic linebuffer device")
(replace (FDEV EOFP) of DEV with EOFMETHOD))
(replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE 'FDEV DEV)))
(* ; "Copy the basic linebuffer device")
(replace (FDEV EOFP) of DEV with EOFMETHOD))
STREAM])
(\PROMPTFORWORDBIN
@@ -650,7 +648,7 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
(SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG))
(for I from 1 to 8 do (ECHOCHAR I 'IGNORE CHATSERVERTTBL)
(ECHOCHAR I 'IGNORE ASKUSERTTBL))
(ECHOCHAR I 'IGNORE ASKUSERTTBL))
(ECHOCHAR (CHARCODE CR)
'SIMULATE CHATSERVERTTBL)
@@ -715,29 +713,25 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
(DECLARE%: EVAL@COMPILE
[PROGN (PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR)
(CHECK (type? CHARTABLE TABLE))
(CHECK (type? CHARTABLE TABLE))
(* ;
 "0 is either NONE.TC, REAL.CCE, or OTHER.RC")
(COND
((IGREATERP CHAR \MAXTHINCHAR)
(OR (AND (fetch (CHARTABLE NSCHARHASH)
of TABLE)
(GETHASH CHAR (fetch (CHARTABLE
NSCHARHASH)
of TABLE)))
0))
(T (\GETBASEBYTE TABLE CHAR])
 "0 is either NONE.TC, REAL.CCE, or OTHER.RC")
(COND
((IGREATERP CHAR \MAXTHINCHAR)
(OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
(GETHASH CHAR (fetch (CHARTABLE NSCHARHASH)
of TABLE)))
0))
(T (\GETBASEBYTE TABLE CHAR])
(PUTPROPS \SYNCODE MACRO [OPENLAMBDA (TABLE CHAR)
(CHECK (type? CHARTABLE TABLE))
(COND
((IGREATERP CHAR \MAXTHINCHAR)
(OR (AND (fetch (CHARTABLE NSCHARHASH)
of TABLE)
(GETHASH CHAR (fetch (CHARTABLE
NSCHARHASH)
of TABLE)))
0))
(T (\GETBASEBYTE TABLE CHAR])]
(CHECK (type? CHARTABLE TABLE))
(COND
((IGREATERP CHAR \MAXTHINCHAR)
(OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
(GETHASH CHAR (fetch (CHARTABLE NSCHARHASH)
of TABLE)))
0))
(T (\GETBASEBYTE TABLE CHAR])]
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
@@ -773,10 +767,9 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
(READVISE MENU CHAT RINGBELLS)
)
(DEFCOMMAND "QUIT" ()
(RETFROM 'CHATSERVEROPENFN))
(DEFCOMMAND "QUIT" NIL (RETFROM 'CHATSERVEROPENFN))
(DEFCOMMAND "SAY" (&REST LINE)
(DEFCOMMAND "SAY" (&REST LINE)
[MAPC \PROCESSES (FUNCTION (LAMBDA (PROC)
(CL:WHEN (STRPOS "CHAT.SERVER" (PROCESS.NAME PROC))
(MAPRINT LINE (IF (EQ PROC (THIS.PROCESS))
@@ -795,53 +788,13 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
(ADDTOVAR NLAML )
(ADDTOVAR LAMA \REMOTE.BIN CHATSERVEROPENFN)
)
(PRETTYCOMPRINT CHATSERVERCOMS)
(RPAQQ CHATSERVERCOMS
[(FNS CHATSERVER CHATSERVERWHENCLOSEDFN CHATSERVEROPENFN DOBE REQUIRED.LOGIN SERVER-EXEC
SWEEP.OFD \CLEARSYSBUF PROMPTFORWORD \CREATELINEBUFFER \PROMPTFORWORDBIN \REMOTE.BIN
\REMOTE.EXEC.OUTCHARFN CHATSERVER.FONT)
(DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DISPLAYTERMFLG 'DM))
(INITVARS (CHATSERVER.PROFILE)
(\SIMPLEIMAGEOPS))
(P (SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG))
(for I from 1 to 8 do (ECHOCHAR I 'IGNORE CHATSERVERTTBL)
(ECHOCHAR I 'IGNORE ASKUSERTTBL))
(ECHOCHAR (CHARCODE CR)
'SIMULATE CHATSERVERTTBL)
(ECHOCHAR (CHARCODE CR)
'SIMULATE ASKUSERTTBL)
(ECHOCHAR 0 'SIMULATE ASKUSERTTBL)
(ECHOCHAR 0 'SIMULATE CHATSERVERTTBL)))
(ADDVARS (\SWEPT.OFDS))
(DECLARE%: EVAL@COMPILE DONTCOPY (P (CHECKIMPORTS '(LLCHAR ATERM IMAGEIO FILEIO ATBL AOFD)
T)))
[COMS (FNS SIMPLECHATSERVER)
(INITVARS (CHATSERVERWINDOW)
(CHATSERVERWINDOWREGION '(11 228 392 190]
(MACROS \SYNCODE)
(DECLARE%: DONTEVAL@LOAD DOCOPY (FILES CL-TTYEDIT SIMPLECHAT)
(ADVISE MENU CHAT RINGBELLS))
(COMMANDS "QUIT" "SAY")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA CHATSERVEROPENFN])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CHATSERVEROPENFN)
)
(PUTPROPS CHATSERVER COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2216 38509 (CHATSERVER 2226 . 3955) (CHATSERVERWHENCLOSEDFN 3957 . 4304) (
CHATSERVEROPENFN 4306 . 8433) (DOBE 8435 . 8481) (REQUIRED.LOGIN 8483 . 11220) (SERVER-EXEC 11222 .
11395) (SWEEP.OFD 11397 . 11933) (\CLEARSYSBUF 11935 . 12184) (PROMPTFORWORD 12186 . 26531) (
\CREATELINEBUFFER 26533 . 28708) (\PROMPTFORWORDBIN 28710 . 31646) (\REMOTE.BIN 31648 . 33890) (
\REMOTE.EXEC.OUTCHARFN 33892 . 38114) (CHATSERVER.FONT 38116 . 38507)) (39151 41493 (SIMPLECHATSERVER
39161 . 41491)))))
(FILEMAP (NIL (2029 38278 (CHATSERVER 2039 . 3768) (CHATSERVERWHENCLOSEDFN 3770 . 4117) (
CHATSERVEROPENFN 4119 . 8246) (DOBE 8248 . 8294) (REQUIRED.LOGIN 8296 . 11033) (SERVER-EXEC 11035 .
11208) (SWEEP.OFD 11210 . 11746) (\CLEARSYSBUF 11748 . 11997) (PROMPTFORWORD 11999 . 26344) (
\CREATELINEBUFFER 26346 . 28477) (\PROMPTFORWORDBIN 28479 . 31415) (\REMOTE.BIN 31417 . 33659) (
\REMOTE.EXEC.OUTCHARFN 33661 . 37883) (CHATSERVER.FONT 37885 . 38276)) (38905 41247 (SIMPLECHATSERVER
38915 . 41245)))))
STOP

BIN
lispusers/CHATSERVER.LCOM
View File

Binary file not shown.

293
lispusers/ISO8859IO
View File

@@ -1,39 +1,37 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
(FILECREATED " 8-Aug-2021 13:22:31" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>ISO8859IO.;18 22218
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
changes to%: (FNS \8859OUTCHARFN \IBMOUTCHARFN \MACOUTCHARFN)
(FILECREATED " 1-Feb-2026 13:03:18" {WMEDLEY}<lispusers>ISO8859IO.;19 23459
previous date%: " 6-Aug-2021 16:12:42"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>ISO8859IO.;17)
:EDIT-BY rmk
:CHANGES-TO (FNS \MAKERECODEMAP MAKEISOFORMAT \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN)
(VARS ISO8859IOCOMS)
:PREVIOUS-DATE " 8-Aug-2021 13:22:31" {WMEDLEY}<lispusers>ISO8859IO.;11)
(* ; "
Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
")
(PRETTYCOMPRINT ISO8859IOCOMS)
(RPAQQ ISO8859IOCOMS
(
(* ;; "This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding.")
(* ;; "This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding.")
(COMS (* ; "ISO8859/1")
(COMS (* ; "ISO8859/1")
(FNS \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN)
(GLOBALVARS *XEROXTOISO8859MAP* *ISO8859TOXEROXMAP*)
(GLOBALVARS *MCCSTOISO8859MAP* *ISO8859TOMCCSMAP*)
(FNS MAKEISOFORMAT)
(P (MAKEISOFORMAT)))
(COMS (* ; "IBM-PC Extended Ascii")
(COMS (* ; "IBM-PC Extended Ascii")
(FNS \IBMOUTCHARFN \IBMINCCODEFN \IBMPEEKCCODEFN)
(GLOBALVARS *XEROXTOIBMMAP* *IBMTOXEROXMAP*)
(FNS MAKEIBMFORMAT)
(P (MAKEIBMFORMAT)))
(COMS (* ; "Macintosh")
(COMS (* ; "Macintosh")
(FNS \MACOUTCHARFN \MACINCCODEFN \MACPEEKCCODEFN)
(GLOBALVARS *XEROXTOMACMAP* *MACTOXEROXMAP*)
(FNS MAKEMACFORMAT)
(P (MAKEMACFORMAT)))
(COMS (* ; "Independent of char encoding")
(COMS (* ; "Independent of char encoding")
(FNS \COMMONBACKCCODEFN \MAKERECODEMAP \RECODECCODE))))
@@ -51,137 +49,143 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(\8859OUTCHARFN
[LAMBDA (STREAM CHARCODE)
(DECLARE (GLOBALVARS *XEROXTOISO8859MAP*)) (* ; "Edited 8-Aug-2021 13:21 by rmk:")
(* ; "Edited 7-Dec-95 14:34 by ")
(* ; "Edited 7-Dec-95 14:32 by ")
(DECLARE (GLOBALVARS *XEROXTOISO8859MAP*)) (* ; "Edited 1-Feb-2026 10:11 by rmk")
(* ; "Edited 8-Aug-2021 13:21 by rmk:")
(* ; "Edited 7-Dec-95 14:34 by ")
(* ; "Edited 7-Dec-95 14:32 by ")
(* ;; "Converts CHARCODE from internal encoding to ISO8859 before printing.")
(* ;; "Converts CHARCODE from internal encoding to ISO8859 before printing.")
(* ;; "Unconverted codes are left unchanged (no error).")
(* ;; "Unconverted codes are left unchanged (no error).")
(* ;; "If any remaining codes are out of charset 0, the streams external format will be used. ")
(* ;; "If any remaining codes are out of charset 0, the streams external format will be used. ")
(IF (EQ CHARCODE (CHARCODE EOL))
THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
(\BOUTEOL STREAM)
(\BOUTEOL STREAM)
ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM)
(IPLUS16 1 DATUM))
(\BOUT STREAM (IF (IGREATERP CHARCODE 127)
THEN
(IPLUS16 1 DATUM))
(\BOUT STREAM (IF (IGREATERP CHARCODE 127)
THEN
(* ;; "We know that ISO doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128")
(* ;; "We know that ISO doesn't have floating accents, so only singletons are returned. We also know that it agrees with MCCS on first 128, except for cirumflex and underscore")
(\RECODECCODE CHARCODE *XEROXTOISO8859MAP*)
ELSE CHARCODE])
(\RECODECCODE CHARCODE *MCCSTOISO8859MAP*)
ELSE CHARCODE])
(\8859INCCODEFN
[LAMBDA (STRM COUNTP) (* ; "Edited 6-Aug-2021 16:10 by rmk:")
(* ; "Edited 7-Dec-95 15:24 by ")
(* ; "Edited 7-Dec-95 15:19 by ")
[LAMBDA (STRM COUNTP) (* ; "Edited 1-Feb-2026 10:10 by rmk")
(* ; "Edited 6-Aug-2021 16:10 by rmk:")
(* ; "Edited 7-Dec-95 15:24 by ")
(* ; "Edited 7-Dec-95 15:19 by ")
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1))
(\RECODECCODE (\BIN STRM)
*ISO8859TOXEROXMAP*])
*ISO8859TOMCCSMAP*])
(\8859PEEKCCODEFN
[LAMBDA (STRM NOERROR) (* ; "Edited 5-May-2021 17:44 by rmk:")
(* ; "Edited 3-Jan-96 14:21 by ")
(* ; "Edited 7-Dec-95 15:51 by ")
(* ; "Edited 7-Dec-95 15:19 by ")
[LAMBDA (STRM NOERROR) (* ; "Edited 1-Feb-2026 10:10 by rmk")
(* ; "Edited 5-May-2021 17:44 by rmk:")
(* ; "Edited 3-Jan-96 14:21 by ")
(* ; "Edited 7-Dec-95 15:51 by ")
(* ; "Edited 7-Dec-95 15:19 by ")
(\RECODECCODE (\PEEKCCODE STRM NOERROR)
*ISO8859TOXEROXMAP*])
*ISO8859TOMCCSMAP*])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *XEROXTOISO8859MAP* *ISO8859TOXEROXMAP*)
(GLOBALVARS *MCCSTOISO8859MAP* *ISO8859TOMCCSMAP*)
)
(DEFINEQ
(MAKEISOFORMAT
[LAMBDA NIL (* ; "Edited 5-Aug-2021 22:15 by rmk:")
(* ; "Edited 9-Mar-99 17:19 by rmk:")
(* ; "Edited 7-Dec-95 16:24 by ")
(* ; "Edited 7-Dec-95 16:20 by ")
(LET [(XEROXTOISO '((61217 160)
(61291 166)
(8994 168)
(211 169)
(227 170)
(61290 172)
(61219 173)
(210 174)
(9086 175)
(8999 180)
(203 184)
(209 185)
(235 186)
(61729 192)
(61730 193)
(61731 194)
(61732 195)
(61735 196)
(61736 197)
(225 198)
(61741 199)
(61744 200)
(61745 201)
(61746 202)
(61749 203)
(61758 204)
(61759 205)
(61760 206)
(61764 207)
(226 208)
(61772 209)
(61775 210)
(61776 211)
(61777 212)
(61778 213)
(61780 214)
(180 215)
(233 216)
(61791 217)
(61792 218)
(61793 219)
(61797 220)
(61803 221)
(236 222)
(251 223)
(61857 224)
(61858 225)
(61859 226)
(61860 227)
(61863 228)
(61864 229)
(241 230)
(61869 231)
(61872 232)
(61873 233)
(61874 234)
(61877 235)
(61886 236)
(61887 237)
(61888 238)
(61892 239)
(243 240)
(61900 241)
(61903 242)
(61904 243)
(61905 244)
(61906 245)
(61908 246)
(184 247)
(249 248)
(61919 249)
(61920 250)
(61921 251)
(61925 252)
(61931 253)
(252 254)
(61933 255)
(61805 376]
(SETQ *XEROXTOISO8859MAP* (\MAKERECODEMAP XEROXTOISO))
(SETQ *ISO8859TOXEROXMAP* (\MAKERECODEMAP XEROXTOISO T)))
[LAMBDA NIL (* ; "Edited 1-Feb-2026 11:18 by rmk")
(* ; "Edited 5-Aug-2021 22:15 by rmk:")
(* ; "Edited 9-Mar-99 17:19 by rmk:")
(* ; "Edited 7-Dec-95 16:24 by ")
(* ; "Edited 7-Dec-95 16:20 by ")
(LET [(MCCSTOISO '(("0,255" "0,136")
("0,254" "0,137")
("357,41" "0,240")
("357,153" "0,246")
("43,42" "0,250")
("0,323" "0,251")
("0,343" "0,252")
("357,152" "0,254")
("357,43" "0,255")
("0,322" "0,256")
("43,176" "0,257")
("43,47" "0,264")
("0,313" "0,270")
("0,321" "0,271")
("0,353" "0.272")
("361,41" "0,300")
("361,42" "0,301")
("361,43" "0,302")
("361,44" "0,303")
("361,47" "0,304")
("361,50" "0,305")
("0,341" "0,306")
("361,55" "0,307")
("361,60" "0,310")
("361,61" "0,311")
("361,62" "0,312")
("361,65" "0,313")
("361,76" "0,314")
("361,77" "0,315")
("361,100" "0,316")
("361,104" "0,317")
("0,342" "0,320")
("361,114" "0,321")
("361,117" "0,322")
("361,120" "0,323")
("361,121" "0,324")
("361,122" "0,325")
("361,124" "0,326")
("0,264" "0,327")
("0,351" "0,330")
("361,137" "0,331")
("361,140" "0,332")
("361,141" "0,333")
("361,145" "0,334")
("361,153" "0,335")
("0,354" "0,336")
("0,373" "0,337")
("361,241" "0,340")
("361,242" "0,341")
("361,243" "0,342")
("361,244" "0,343")
("361,247" "0,344")
("361,250" "0,345")
("0,361" "0,346")
("361,255" "0,347")
("361,260" "0,350")
("361,261" "0,351")
("361,262" "0,352")
("361,265" "0,353")
("361,276" "0,354")
("361,277" "0,355")
("361,300" "0,356")
("361,304" "0,357")
("0,363" "0,360")
("361,314" "0,361")
("361,317" "0,362")
("361,320" "0,363")
("361,321" "0,364")
("361,322" "0,365")
("361,324" "0,366")
("0,270" "0,367")
("0,371" "0,370")
("361,337" "0,371")
("361,340" "0,372")
("361,341" "0,373")
("361,345" "0,374")
("361,353" "0,375")
("0,374" "0,376")
("361,355" "0,377")
("361,155" "Meta,170"]
(SETQ *MCCSTOISO8859MAP* (\MAKERECODEMAP MCCSTOISO))
(SETQ *ISO8859TOMCCSMAP* (\MAKERECODEMAP MCCSTOISO T)))
(MAKE-EXTERNALFORMAT :ISO8859/1 (FUNCTION \8859INCCODEFN)
(FUNCTION \8859PEEKCCODEFN)
(FUNCTION \COMMONBACKCCODEFN)
@@ -515,26 +519,28 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(\COMMONBACKCCODEFN
[LAMBDA (STRM COUNTP) (* ; "Edited 6-Aug-2021 16:12 by rmk:")
(* ; "Edited 8-Dec-95 13:26 by ")
(DECLARE (USEDFREE *BYTECOUNTER*))
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN (\BACKFILEPTR STRM)
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
T)])
(\MAKERECODEMAP
[LAMBDA (CODEMAP INVERTED) (* ; "Edited 1-Feb-2026 13:03 by rmk")
(* ; "Edited 9-Mar-99 17:23 by rmk:")
(* ;; "Produces a map array for use by \RECODECCODE. The map array is a 256-array of either NIL or 256-arrays, so that space isn't allocated for widely separated codes.")
(DECLARE (USEDFREE FASTRECODEMAPCACHE))
(CL:WHEN INVERTED
[SETQ CODEMAP (FOR C IN CODEMAP COLLECT (LIST (CADR C)
(CAR C])
(FOR M (MAPARRAY _ (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL))
CSMAP IN CODEMAP UNLESS (EQ (CAR M)
(CADR M))
DO (CL:UNLESS (SETQ CSMAP (CL:SVREF MAPARRAY (LRSH (CAR M)
8)))
(SETQ CSMAP (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL))
(* ;; "Produces a map array for use by \RECODECCODE. The map array is a 256-array of either NIL or 256-arrays, so that space isn't allocated for widely separated codes.")
(DECLARE (USEDFREE FASTRECODEMAPCACHE))
(CL:WHEN INVERTED
[SETQ CODEMAP (FOR C IN CODEMAP COLLECT (LIST (CADR C)
(CAR C])
(FOR M LEFT RIGHT (MAPARRAY ¬ (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL))
CSMAP IN CODEMAP eachtime (SETQ LEFT (CAR M))
(SETQ RIGHT (CADR M))
(CL:UNLESS (CHARCODEP LEFT)
(SETQ LEFT (CHARCODE.DECODE LEFT)))
(CL:UNLESS (CHARCODEP RIGHT)
(SETQ RIGHT (CHARCODE.DECODE RIGHT)))
UNLESS (EQ LEFT RIGHT) DO (CL:UNLESS (SETQ CSMAP (CL:SVREF MAPARRAY (LRSH LEFT 8)))
(SETQ CSMAP (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL))
(CL:SETF (CL:SVREF MAPARRAY (LRSH LEFT 8))
@@ -546,12 +552,11 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
[LAMBDA (CODE MAPARRAY) (* ; "Edited 9-Mar-99 17:28 by rmk:")
(* ; "Edited 21-Jun-95 10:18 by rmk:")
(* ;; "Recodes a singleton charcode. Leaves everything else unchanged.")
(* ;; "Recodes a singleton charcode. Leaves everything else unchanged.")
(LET [(CSMAP (CL:SVREF MAPARRAY (LRSH CODE 8]
(OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255)))
CODE])
)
(PUTPROPS ISO8859IO COPYRIGHT ("Xerox Corporation" 1995 1996 1997 1999 2021))
(DECLARE%: DONTCOPY
(LET [(CSMAP (CL:SVREF MAPARRAY (LRSH CODE 8]
(OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255)))
CODE])
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1840 4502 (\8859OUTCHARFN 1850 . 3287) (\8859INCCODEFN 3289 . 3879) (\8859PEEKCCODEFN

BIN
lispusers/ISO8859IO.LCOM
View File

Binary file not shown.

46
sources/ADIR
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "15-Oct-2025 15:20:48" {WMEDLEY}<sources>ADIR.;62 70135
(FILECREATED " 5-Feb-2026 10:27:45" {WMEDLEY}<sources>ADIR.;67 70247
:EDIT-BY rmk
:CHANGES-TO (MACROS \UPF.EXTRACT)
:CHANGES-TO (FNS INTERPRET.REM.CM)
:PREVIOUS-DATE " 6-Feb-2025 17:48:54" {WMEDLEY}<sources>ADIR.;61)
:PREVIOUS-DATE " 1-Feb-2026 13:17:10" {WMEDLEY}<sources>ADIR.;66)
(PRETTYCOMPRINT ADIRCOMS)
@@ -1179,7 +1179,8 @@
HERALDSTRING])
(INTERPRET.REM.CM
[LAMBDA (RETFLG) (* ; "Edited 15-Mar-2021 12:27 by larry")
[LAMBDA (RETFLG) (* ; "Edited 1-Feb-2026 17:49 by rmk")
(* ; "Edited 15-Mar-2021 12:27 by larry")
(DECLARE (GLOBALVARS STARTUPFORM))
(* ;;; "Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote. If it's a string, it will be unread,, else the form will be evaluated at the next prompt. For use in INIT.LISP, among others. If RETFLG is true, the expression read is simply returned")
@@ -1187,23 +1188,22 @@
(PROG ([FILE (INFILEP (PACKFILENAME 'HOST '{DSK} 'BODY (UNIX-GETENV "LDEREMCM"]
COM)
(OR FILE (RETURN))
(SETQ FILE (OPENSTREAM FILE 'INPUT))
[SETQ FILE (OPENSTREAM FILE 'INPUT 'OLD '((:EXTERNAL-FORMAT :UTF-8]
(COND
[[AND (IGREATERP (GETFILEINFO FILE 'LENGTH)
([AND (IGREATERP (GETFILEINFO FILE 'LENGTH)
0)
(EQ (SKIPSEPRS FILE T)
'%")
(SETQ COM (CAR (NLSETQ (READ FILE T]
(CLOSEF FILE)
(COND
(RETFLG (* ; "Save it to return"))
(T (* ; "Unread a string")
(CL:UNLESS RETFLG (* ;
 "Save it to return; otherwise unread a string")
(* ;
 "RMK: Replace CR and LF by space to avoid EOL convention issues")
(for I from 1 to (NCHARS COM) when (FMEMB (NTHCHARCODE COM I)
(CHARCODE (CR LF EOL)))
do (RPLCHARCODE COM I (CHARCODE EOL)))
(BKSYSBUF COM]
(for I from 1 to (NCHARS COM) when (FMEMB (NTHCHARCODE COM I)
(CHARCODE (CR LF EOL)))
do (RPLCHARCODE COM I (CHARCODE EOL)))
(BKSYSBUF COM)))
(T (CLOSEF FILE)))
(RETURN (COND
(RETFLG COM)
@@ -1282,14 +1282,14 @@
(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3170 15997 (DELFILE 3180 . 3341) (FULLNAME 3343 . 3710) (INFILE 3712 . 3971) (INFILEP
3973 . 4108) (IOFILE 4110 . 4361) (OPENFILE 4363 . 4666) (OPENSTREAM 4668 . 9008) (OUTFILE 9010 . 9272
) (OUTFILEP 9274 . 9410) (RENAMEFILE 9412 . 9718) (SIMPLE.FINDFILE 9720 . 10130) (VMEMSIZE 10132 .
10299) (\COPYSYS 10301 . 14592) (\FLUSHVM 14594 . 15666) (\LOGOUT0 15668 . 15995)) (16496 41156 (
UNPACKFILENAME.STRING 16506 . 38342) (\UPF.DIRECTORY 38344 . 41154)) (42741 45047 (UNPACKFILENAME
42751 . 42937) (LASTCHPOS 42939 . 43633) (FILENAMEFIELD 43635 . 43929) (FILENAMEFIELD.STRING 43931 .
44335) (PACKFILENAME 44337 . 44680) (PACKFILENAME.STRING 44682 . 45045)) (59517 60430 (
FILEDIRCASEARRAY 59527 . 60428)) (60597 67894 (LOGOUT 60607 . 61652) (MAKESYS 61654 . 63283) (SYSOUT
63285 . 64837) (SAVEVM 64839 . 65639) (HERALD 65641 . 65801) (INTERPRET.REM.CM 65803 . 67517) (
\USEREVENT 67519 . 67892)) (68076 69803 (USERNAME 68086 . 69042) (SETUSERNAME 69044 . 69801)))))
(FILEMAP (NIL (3171 15998 (DELFILE 3181 . 3342) (FULLNAME 3344 . 3711) (INFILE 3713 . 3972) (INFILEP
3974 . 4109) (IOFILE 4111 . 4362) (OPENFILE 4364 . 4667) (OPENSTREAM 4669 . 9009) (OUTFILE 9011 . 9273
) (OUTFILEP 9275 . 9411) (RENAMEFILE 9413 . 9719) (SIMPLE.FINDFILE 9721 . 10131) (VMEMSIZE 10133 .
10300) (\COPYSYS 10302 . 14593) (\FLUSHVM 14595 . 15667) (\LOGOUT0 15669 . 15996)) (16497 41157 (
UNPACKFILENAME.STRING 16507 . 38343) (\UPF.DIRECTORY 38345 . 41155)) (42742 45048 (UNPACKFILENAME
42752 . 42938) (LASTCHPOS 42940 . 43634) (FILENAMEFIELD 43636 . 43930) (FILENAMEFIELD.STRING 43932 .
44336) (PACKFILENAME 44338 . 44681) (PACKFILENAME.STRING 44683 . 45046)) (59518 60431 (
FILEDIRCASEARRAY 59528 . 60429)) (60598 68006 (LOGOUT 60608 . 61653) (MAKESYS 61655 . 63284) (SYSOUT
63286 . 64838) (SAVEVM 64840 . 65640) (HERALD 65642 . 65802) (INTERPRET.REM.CM 65804 . 67629) (
\USEREVENT 67631 . 68004)) (68188 69915 (USERNAME 68198 . 69154) (SETUSERNAME 69156 . 69913)))))
STOP

BIN
sources/ADIR.LCOM
View File

Binary file not shown.

80
sources/ATERM
View File

@@ -1,16 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "20-Jul-2022 17:05:17" {DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>ATERM.;5 57463
(FILECREATED " 9-Feb-2026 15:49:51" {WMEDLEY}<sources>ATERM.;7 56918
:CHANGES-TO (FNS \CHDEL1)
:EDIT-BY rmk
:PREVIOUS-DATE "19-Jul-2022 22:49:20"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>ATERM.;4)
:CHANGES-TO (FNS \CREATELINEBUFFER)
:PREVIOUS-DATE "20-Jul-2022 17:05:17" {WMEDLEY}<sources>ATERM.;5)
(* ; "
Copyright (c) 1982-1988, 1990, 2021 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT ATERMCOMS)
@@ -915,39 +912,33 @@ Copyright (c) 1982-1988, 1990, 2021 by Venue & Xerox Corporation.
(RETURN STREAM])
(\CREATELINEBUFFER
[LAMBDA (TERMINAL.STREAM) (* ; "Edited 29-Apr-2021 09:38 by rmk:")
[LAMBDA (TERMINAL.STREAM) (* ; "Edited 9-Feb-2026 15:49 by rmk")
(* ; "Edited 29-Apr-2021 09:38 by rmk:")
(* ;;
 "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).")
(* ;;
 "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).")
(LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((CHARSET T]
(LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((:EXTERNAL-FORMAT :THROUGH16]
(DEV (fetch (STREAM DEVICE) of STREAM))
EOFMETHOD)
(replace LINEBUFSTATE of STREAM with READING.LBS)
(replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM
\KEYBOARD.STREAM))
(replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM \KEYBOARD.STREAM))
(replace USERCLOSEABLE of STREAM with NIL)
(replace USERVISIBLE of STREAM with NIL)
(* ;
 "Other linebuffer fields default properly")
(replace USERVISIBLE of STREAM with NIL) (* ;
 "Other linebuffer fields default properly")
[replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM)
(CL:FUNCALL \RefillBufferFn]
(CL:FUNCALL \RefillBufferFn]
(replace (STREAM EOLCONVENTION) of STREAM with CR.EOLC)
(* ;
 "RMK: Terminal is CR, even if stream default is LF")
(if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of
TERMINAL.STREAM
))
'NILL))
(* ;
 "RMK: Terminal is CR, even if stream default is LF")
(if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of TERMINAL.STREAM))
'NILL))
then
(* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.")
(* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.")
(replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE
'FDEV DEV)))
(* ;
 "Copy the basic linebuffer device")
(replace (FDEV EOFP) of DEV with EOFMETHOD))
(replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE 'FDEV DEV)))
(* ; "Copy the basic linebuffer device")
(replace (FDEV EOFP) of DEV with EOFMETHOD))
STREAM])
(\LINEBUF.READP
@@ -1142,20 +1133,19 @@ Copyright (c) 1982-1988, 1990, 2021 by Venue & Xerox Corporation.
(ADDTOVAR LAMA VIDEOCOLOR TERMINAL-OUTPUT TERMINAL-INPUT)
)
(PUTPROPS ATERM COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2982 32059 (BKLINBUF 2992 . 3467) (CLEARBUF 3469 . 4801) (LINBUF 4803 . 4989) (
PAGEFULLFN 4991 . 6472) (SETLINELENGTH 6474 . 6670) (SYSBUF 6672 . 6858) (TERMCHARWIDTH 6860 . 7277) (
TERMINAL-INPUT 7279 . 7847) (TERMINAL-OUTPUT 7849 . 8435) (\CHDEL1 8437 . 8826) (\CLOSELINE 8828 .
9117) (\DECPARENCOUNT 9119 . 10702) (\ECHOCHAR 10704 . 11396) (\FILLBUFFER 11398 . 24389) (
\FILLBUFFER.WORDSEPRP 24391 . 24636) (\FILLBUFFER.BACKUP 24638 . 24817) (\GETCHAR 24819 . 25208) (
\INCPARENCOUNT 25210 . 27822) (\RESETLINE 27824 . 28148) (\RESETTERMINAL 28150 . 28914) (\SAVELINEBUF
28916 . 30887) (\STOPSCROLL? 30889 . 32057)) (32262 36118 (\DSCCOUT 32272 . 35412) (\INITBCPLDISPLAY
35414 . 36116)) (36311 37561 (VIDEOCOLOR 36321 . 37559)) (38329 44183 (\PEEKREFILL 38339 . 42450) (
\READREFILL 42452 . 43046) (\RATOM/RSTRING-REFILL 43048 . 43626) (\READCREFILL 43628 . 44181)) (44184
46013 (DRIBBLE 44194 . 45795) (DRIBBLEFILE 45797 . 46011)) (46014 52689 (\SETUP.DEFAULT.LINEBUF 46024
. 48481) (\CREATELINEBUFFER 48483 . 50905) (\LINEBUF.READP 50907 . 51256) (\LINEBUF.EOFP 51258 .
51597) (\LINEBUF.PEEKBIN 51599 . 51806) (\OPENLINEBUF 51808 . 52687)) (52764 54003 (LINEBUFFER-EOFP
52774 . 53232) (LINEBUFFER-SKIPSEPRS 53234 . 54001)) (54360 54634 (\INTERMP 54370 . 54501) (\OUTTERMP
54503 . 54632)))))
(FILEMAP (NIL (2854 31931 (BKLINBUF 2864 . 3339) (CLEARBUF 3341 . 4673) (LINBUF 4675 . 4861) (
PAGEFULLFN 4863 . 6344) (SETLINELENGTH 6346 . 6542) (SYSBUF 6544 . 6730) (TERMCHARWIDTH 6732 . 7149) (
TERMINAL-INPUT 7151 . 7719) (TERMINAL-OUTPUT 7721 . 8307) (\CHDEL1 8309 . 8698) (\CLOSELINE 8700 .
8989) (\DECPARENCOUNT 8991 . 10574) (\ECHOCHAR 10576 . 11268) (\FILLBUFFER 11270 . 24261) (
\FILLBUFFER.WORDSEPRP 24263 . 24508) (\FILLBUFFER.BACKUP 24510 . 24689) (\GETCHAR 24691 . 25080) (
\INCPARENCOUNT 25082 . 27694) (\RESETLINE 27696 . 28020) (\RESETTERMINAL 28022 . 28786) (\SAVELINEBUF
28788 . 30759) (\STOPSCROLL? 30761 . 31929)) (32134 35990 (\DSCCOUT 32144 . 35284) (\INITBCPLDISPLAY
35286 . 35988)) (36183 37433 (VIDEOCOLOR 36193 . 37431)) (38201 44055 (\PEEKREFILL 38211 . 42322) (
\READREFILL 42324 . 42918) (\RATOM/RSTRING-REFILL 42920 . 43498) (\READCREFILL 43500 . 44053)) (44056
45885 (DRIBBLE 44066 . 45667) (DRIBBLEFILE 45669 . 45883)) (45886 52246 (\SETUP.DEFAULT.LINEBUF 45896
. 48353) (\CREATELINEBUFFER 48355 . 50462) (\LINEBUF.READP 50464 . 50813) (\LINEBUF.EOFP 50815 .
51154) (\LINEBUF.PEEKBIN 51156 . 51363) (\OPENLINEBUF 51365 . 52244)) (52321 53560 (LINEBUFFER-EOFP
52331 . 52789) (LINEBUFFER-SKIPSEPRS 52791 . 53558)) (53917 54191 (\INTERMP 53927 . 54058) (\OUTTERMP
54060 . 54189)))))
STOP

BIN
sources/ATERM.LCOM
View File

Binary file not shown.

298
sources/EXTERNALFORMAT
View File

@@ -1,12 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Jan-2026 21:09:02" {WMEDLEY}<sources>EXTERNALFORMAT.;92 39722
(FILECREATED " 9-Feb-2026 15:54:22" {WMEDLEY}<sources>EXTERNALFORMAT.;120 47422
:EDIT-BY rmk
:CHANGES-TO (FNS \EXTERNALFORMAT)
:CHANGES-TO (VARS EXTERNALFORMATCOMS)
(FNS \CREATE.THROUGH16.EXTERNALFORMAT \CREATE.THROUGH.EXTERNALFORMAT)
:PREVIOUS-DATE "24-Apr-2025 08:43:01" {WMEDLEY}<sources>EXTERNALFORMAT.;91)
:PREVIOUS-DATE " 6-Feb-2026 23:21:32" {WMEDLEY}<sources>EXTERNALFORMAT.;116)
(PRETTYCOMPRINT EXTERNALFORMATCOMS)
@@ -19,10 +20,12 @@
(SYSRECORDS EXTERNALFORMAT)
(FNS \EXTERNALFORMAT MAKE-EXTERNALFORMAT \EXTERNALFORMAT.DEFPRINT)
(FNS \INSTALL.EXTERNALFORMAT \REMOVE.EXTERNALFORMAT FIND-FORMAT)
(FNS SYSTEM-EXTERNALFORMAT)
(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*)
(EXPORT (GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*))
(INITVARS (*EXTERNALFORMATS* NIL)
(*DEFAULT-EXTERNALFORMAT* :MCCS))
(COMS (FNS SYSTEM-EXTERNALFORMAT MTOSYSSTRING SYSTOMSTRING)
(EXPORT (GLOBALVARS *SYSTEM-EXTERNALFORMAT*))
(INITVARS (*SYSTEM-EXTERNALFORMAT* :UTF-8)))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'EXTERNALFORMAT (FUNCTION
\EXTERNALFORMAT.DEFPRINT
]
@@ -30,7 +33,8 @@
(* ;; "Generic functions not compiled open (originally on LLREAD)")
(FNS \OUTCHAR \INCCODE \BACKCCODE \BACKCCODE.EOLC \PEEKCCODE \PEEKCCODE.EOLC
\INCCODE.EOLC \FORMATBYTESTREAM \FORMATBYTESTRING \CHECKEOLC.CRLF)
\INCCODE.EOLC \FORMATBYTESTREAM \CHECKEOLC.CRLF)
(FNS MCCSTOFORMATBYTES FORMATBYTESTOMCCS)
(DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CHECKEOLC))
(RESOURCES \FORMATBYTESTRING.STREAM))
(INITRESOURCES \FORMATBYTESTRING.STREAM))
@@ -38,10 +42,12 @@
(FNS \NULLDEVICE \NULL.OPENFILE)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\NULLDEVICE]
(COMS
(* ;; "Also from FILEIO, but not clear that this is or ever has been used.")
(* ;; "Also from FILEIO.")
(FNS \CREATE.THROUGH.EXTERNALFORMAT \THROUGHIN \THROUGHBACKCCODE \THROUGHOUTCHARFN)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT])
(FNS \CREATE.THROUGH.EXTERNALFORMAT \CREATE.THROUGH16.EXTERNALFORMAT \THROUGHIN
\THROUGHBACKCCODE \THROUGHOUTCHARFN)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT)
(\CREATE.THROUGH16.EXTERNALFORMAT])
@@ -67,15 +73,18 @@
(EF1 POINTER) (* ;
 "Extra fields for use of particular formats. Possibly to hold standardized translation tables")
(EF2 POINTER)
(FORMATBYTESTRINGFN POINTER) (* ; "Translates an internal string into a string containing the bytes that represent that string in this format")
(MCCSTOFORMATBYTESFN POINTER) (* ; "Translates an MCCS string into a string containing the bytes that represent that string in this format")
(FORMATCHARSETFN POINTER) (* ;
 "If present, apply by \GENERIC.CHARSET")
))
(FORMATBYTESTOMCCSFN POINTER)) (* ;
 "Translates format bytes into a string containing the corresponding MCCS codes")
)
)
(/DECLAREDATATYPE 'EXTERNALFORMAT
'(FLAG (BITS 2)
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER)
'((EXTERNALFORMAT 0 (FLAGBITS . 0))
(EXTERNALFORMAT 0 (BITS . 17))
(EXTERNALFORMAT 0 (FLAGBITS . 48))
@@ -88,8 +97,9 @@
(EXTERNALFORMAT 12 POINTER)
(EXTERNALFORMAT 14 POINTER)
(EXTERNALFORMAT 16 POINTER)
(EXTERNALFORMAT 18 POINTER))
'20)
(EXTERNALFORMAT 18 POINTER)
(EXTERNALFORMAT 20 POINTER))
'22)
(* "END EXPORTED DEFINITIONS")
@@ -97,7 +107,8 @@
(/DECLAREDATATYPE 'EXTERNALFORMAT
'(FLAG (BITS 2)
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER)
'((EXTERNALFORMAT 0 (FLAGBITS . 0))
(EXTERNALFORMAT 0 (BITS . 17))
(EXTERNALFORMAT 0 (FLAGBITS . 48))
@@ -110,8 +121,9 @@
(EXTERNALFORMAT 12 POINTER)
(EXTERNALFORMAT 14 POINTER)
(EXTERNALFORMAT 16 POINTER)
(EXTERNALFORMAT 18 POINTER))
'20)
(EXTERNALFORMAT 18 POINTER)
(EXTERNALFORMAT 20 POINTER))
'22)
(ADDTOVAR SYSTEMRECLST
(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG)
@@ -125,8 +137,9 @@
(FORMATBYTESTREAMFN POINTER)
(EF1 POINTER)
(EF2 POINTER)
(FORMATBYTESTRINGFN POINTER)
(FORMATCHARSETFN POINTER)))
(MCCSTOFORMATBYTESFN POINTER)
(FORMATCHARSETFN POINTER)
(FORMATBYTESTOMCCSFN POINTER)))
)
(DEFINEQ
@@ -199,7 +212,10 @@
(MAKE-EXTERNALFORMAT
[LAMBDA (NAME INCCODEFN PEEKCCODEFN BACKCCODEFN OUTCHARFN FORMATBYTESTREAMFN EOL UNSTABLE
FORMATBYTESTRINGFN DEFAULT FORMATCHARSETFN) (* ; "Edited 8-Dec-2023 22:02 by rmk")
MCCSTOFORMATBYTESFN DEFAULT FORMATCHARSETFN FORMATBYTESTOMCCSFN)
(* ; "Edited 5-Feb-2026 14:26 by rmk")
(* ; "Edited 2-Feb-2026 23:04 by rmk")
(* ; "Edited 8-Dec-2023 22:02 by rmk")
(* ; "Edited 3-Jul-2022 00:35 by rmk")
(* ; "Edited 10-Sep-2021 19:47 by rmk:")
@@ -210,17 +226,13 @@
*DEFAULT-EXTERNALFORMAT*
DEFAULT)]
(CL:UNLESS INCCODEFN
(SETQ INCCODEFN (FETCH (EXTERNALFORMAT INCCODEFN)
DEF)))
(SETQ INCCODEFN (FETCH (EXTERNALFORMAT INCCODEFN) OF DEF)))
(CL:UNLESS PEEKCCODEFN
(SETQ PEEKCCODEFN (FETCH (EXTERNALFORMAT PEEKCCODEFN)
DEF)))
(SETQ PEEKCCODEFN (FETCH (EXTERNALFORMAT PEEKCCODEFN) OF DEF)))
(CL:UNLESS BACKCCODEFN
(SETQ BACKCCODEFN (FETCH (EXTERNALFORMAT BACKCCODEFN)
DEF)))
(SETQ BACKCCODEFN (FETCH (EXTERNALFORMAT BACKCCODEFN) OF DEF)))
(CL:UNLESS OUTCHARFN
(SETQ OUTCHARFN (FETCH (EXTERNALFORMAT OUTCHARFN)
DEF)))])
(SETQ OUTCHARFN (FETCH (EXTERNALFORMAT OUTCHARFN) OF DEF)))])
(SETQ EOL (SELECTC EOL
((LIST 'LF LF.EOLC)
LF.EOLC)
@@ -240,7 +252,8 @@
EOLVALID _ EOL
EOL _ (OR EOL LF.EOLC)
UNSTABLE _ UNSTABLE
FORMATBYTESTRINGFN _ FORMATBYTESTRINGFN
MCCSTOFORMATBYTESFN _ MCCSTOFORMATBYTESFN
FORMATBYTESTOMCCSFN _ FORMATBYTESTOMCCSFN
FORMATCHARSETFN _ (OR FORMATCHARSETFN (FUNCTION NILL])
(\EXTERNALFORMAT.DEFPRINT
@@ -306,22 +319,52 @@
OF EF)))
(CL:UNLESS NOERROR (ERROR NAME "is not an external format"])
)
(DEFINEQ
(SYSTEM-EXTERNALFORMAT
[LAMBDA NIL (* ; "Edited 10-Oct-2022 11:55 by lmm")
(* ; "Edited 7-Jul-2022 10:41 by rmk")
(FOR X IN '("LC_CTYPE" "LC_ALL" "LANG") WHEN (STRPOS ".UTF-8" (UNIX-GETENV X))
DO (RETURN :UTF-8) FINALLY (RETURN :THROUGH])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*)
)
(* "END EXPORTED DEFINITIONS")
(RPAQ? *EXTERNALFORMATS* NIL)
(RPAQ? *DEFAULT-EXTERNALFORMAT* :MCCS)
(DEFINEQ
(SYSTEM-EXTERNALFORMAT
[LAMBDA NIL (* ; "Edited 6-Feb-2026 11:29 by rmk")
(* ; "Edited 31-Jan-2026 18:51 by rmk")
(* ; "Edited 10-Oct-2022 11:55 by lmm")
(* ; "Edited 7-Jul-2022 10:41 by rmk")
(* ;; "Returns the name, sets the global. For now, UTF-8 or through, could be something else.")
(fetch (EXTERNALFORMAT NAME) of (SETQ *SYSTEM-EXTERNALFORMAT*
(FIND-FORMAT (FOR X IN '("LC¬CTYPE" "LC¬ALL" "LANG")
WHEN (STRPOS ".UTF-8" (UNIX-GETENV X))
DO (RETURN :UTF-8) FINALLY (RETURN :THROUGH])
(MTOSYSSTRING
[LAMBDA (MSTRING) (* ; "Edited 6-Feb-2026 00:20 by rmk")
(MCCSTOFORMATBYTES *SYSTEM-EXTERNALFORMAT* (MKSTRING MSTRING])
(SYSTOMSTRING
[LAMBDA (SYSTRING) (* ; "Edited 5-Feb-2026 23:36 by rmk")
(* ;; "SYSSTRING is presumably shared with Unix, guarantee a copy on the way out")
(CONCAT (FORMATBYTESTOMCCS *SYSTEM-EXTERNALFORMAT* SYSTRING])
)
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *SYSTEM-EXTERNALFORMAT*)
)
(* "END EXPORTED DEFINITIONS")
(RPAQ? *SYSTEM-EXTERNALFORMAT* :UTF-8)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(DEFPRINT 'EXTERNALFORMAT (FUNCTION \EXTERNALFORMAT.DEFPRINT))
@@ -524,28 +567,6 @@
(freplace (STREAM ENDOFSTREAMOP) of BYTESTREAM with (FUNCTION NILL)))
BYTESTREAM])
(\FORMATBYTESTRING
[LAMBDA (STREAM STRING) (* ; "Edited 19-Mar-2024 18:24 by rmk")
(* ; "Edited 10-Jul-2022 16:39 by rmk")
(* ; "Edited 22-Jun-2022 11:07 by rmk")
(* ; "Edited 18-Jun-2022 22:04 by rmk")
(WITH-RESOURCE \FORMATBYTESTRING.STREAM (\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(LET [FSTRING NBYTES (BYTESTRINGFN (FETCH (EXTERNALFORMAT FORMATBYTESTRINGFN)
OF (FETCH (STREAM EXTERNALFORMAT) OF STREAM]
(IF BYTESTRINGFN
THEN (CL:WHEN (SETQ FSTRING (APPLY* BYTESTRINGFN STREAM STRING
\FORMATBYTESTRING.STREAM))
(MKSTRING FSTRING))
ELSE (\FORMATBYTESTREAM STREAM \FORMATBYTESTRING.STREAM)
(FOR C INPNAME STRING DO (\OUTCHAR \FORMATBYTESTRING.STREAM C))
(SETQ NBYTES (\GETFILEPTR \FORMATBYTESTRING.STREAM))
(\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(SETQ FSTRING (ALLOCSTRING NBYTES))
(FOR I FROM 1 TO NBYTES DO (RPLCHARCODE FSTRING I (\BIN
\FORMATBYTESTRING.STREAM
)))
FSTRING])
(\CHECKEOLC.CRLF
[LAMBDA (STREAM PEEKBINFLG COUNTP EOLC) (* ; "Edited 6-Dec-2023 23:39 by rmk")
(* ; "Edited 17-Oct-2023 11:56 by rmk")
@@ -606,6 +627,66 @@
(CHARCODE CR]
CH])
)
(DEFINEQ
(MCCSTOFORMATBYTES
[LAMBDA (FORMAT MSTRING) (* ; "Edited 6-Feb-2026 18:12 by rmk")
(* ; "Edited 5-Feb-2026 10:24 by rmk")
(* ; "Edited 3-Feb-2026 11:06 by rmk")
(* ; "Edited 19-Mar-2024 18:24 by rmk")
(* ; "Edited 10-Jul-2022 16:39 by rmk")
(* ; "Edited 22-Jun-2022 11:07 by rmk")
(* ; "Edited 18-Jun-2022 22:04 by rmk")
(CL:WHEN MSTRING
(CL:UNLESS (type? EXTERNALFORMAT FORMAT)
(SETQ FORMAT (OR (if (type? STREAM FORMAT)
then (fetch (STREAM EXTERNALFORMAT) of FORMAT)
else (FIND-FORMAT FORMAT))
(\ILLEGAL.ARG FORMAT))))
(LET (FSTRING NBYTES (TOBYTESFN (fetch (EXTERNALFORMAT MCCSTOFORMATBYTESFN) of FORMAT)))
(if TOBYTESFN
then (CL:WHEN (SETQ FSTRING (APPLY* TOBYTESFN MSTRING))
(MKSTRING FSTRING))
else
(* ;;
 "No specific function, fake it by the outchar function. Maybe return NIL if UNSTABLE?")
(WITH-RESOURCE \FORMATBYTESTRING.STREAM (\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(STREAMPROP \FORMATBYTESTRING.STREAM :EXTERNAL-FORMAT FORMAT)
(for C inpname MSTRING do (\OUTCHAR \FORMATBYTESTRING.STREAM C))
(SETQ NBYTES (\GETFILEPTR \FORMATBYTESTRING.STREAM))
(\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(SETQ FSTRING (ALLOCSTRING NBYTES))
(for I from 1 to NBYTES do (RPLCHARCODE FSTRING I (\BIN
\FORMATBYTESTRING.STREAM
)))
FSTRING))))])
(FORMATBYTESTOMCCS
[LAMBDA (FORMAT FSTRING) (* ; "Edited 6-Feb-2026 18:13 by rmk")
(* ;; "Produces an MCCS string with characters that correspond to the format bytes in FSTRING according to FORMAT.")
(CL:WHEN FSTRING
(CL:UNLESS (type? EXTERNALFORMAT FORMAT)
(SETQ FORMAT (OR (if (type? STREAM FORMAT)
then (fetch (STREAM EXTERNALFORMAT) of FORMAT)
else (FIND-FORMAT FORMAT))
(\ILLEGAL.ARG FORMAT))))
(SETQ FSTRING (MKSTRING FSTRING)) (* ; "Should be thin, if bytes")
[LET ((TOMCCSFN (fetch (EXTERNALFORMAT FORMATBYTESTOMCCSFN) of FORMAT))
MSTRING)
(if TOMCCSFN
then (APPLY* TOMCCSFN FSTRING)
else
(* ;; "No specific function, fake it by bouting the FSTRING characters and reading them with \INCCODEFN. ENDOFSTREAMOP is NILL")
(WITH-RESOURCE \FORMATBYTESTRING.STREAM (\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(for B instring FSTRING do (\BOUT \FORMATBYTESTRING.STREAM B))
(\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(STREAMPROP \FORMATBYTESTRING.STREAM :EXTERNAL-FORMAT FORMAT)
(RSTRING \FORMATBYTESTRING.STREAM])])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
@@ -629,7 +710,9 @@
(DECLARE%: EVAL@COMPILE
[PUTDEF '\FORMATBYTESTRING.STREAM 'RESOURCES '(NEW (OPENSTREAM '{NODIRCORE} 'BOTH]
[PUTDEF '\FORMATBYTESTRING.STREAM 'RESOURCES '(NEW (OPENSTREAM '{NODIRCORE} 'BOTH)
NIL
'((ENDOFSTREAMOP NILL]
)
)
@@ -690,31 +773,82 @@
(* ;; "Also from FILEIO, but not clear that this is or ever has been used.")
(* ;; "Also from FILEIO.")
(DEFINEQ
(\CREATE.THROUGH.EXTERNALFORMAT
[LAMBDA NIL (* ; "Edited 24-Jul-2022 08:08 by rmk")
[LAMBDA NIL (* ; "Edited 9-Feb-2026 15:43 by rmk")
(* ; "Edited 5-Feb-2026 13:12 by rmk")
(* ; "Edited 24-Jul-2022 08:08 by rmk")
(* ; "Edited 23-Jun-2021 13:34 by rmk:")
(* ;;; "Create the :THROUGH external format. EOL is adjusted so that the .EOLC callers will not do any conversion.")
(MAKE-EXTERNALFORMAT :THROUGH (FUNCTION \THROUGHIN)
(MAKE-EXTERNALFORMAT :THROUGH [FUNCTION (LAMBDA (STREAM COUNTP)
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1))
(\BIN STREAM]
(FUNCTION \PEEKBIN)
(FUNCTION \THROUGHBACKCCODE)
(FUNCTION \THROUGHOUTCHARFN)
[FUNCTION (LAMBDA (STREAM COUNTP)
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN (\BACKFILEPTR STREAM)
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
T)]
[FUNCTION (LAMBDA (OUTSTREAM CHARCODE)
(CL:WHEN (> CHARCODE \MAXTHINCHAR)
(ERROR ":THROUGH external format can't represent 16 bit characters"))
(\BOUT OUTSTREAM CHARCODE]
NIL
(CL:IF (EQ (CHARCODE CR)
(CHARCODE EOL))
CR.EOLC
LF.EOLC)
NIL
(FUNCTION (LAMBDA (STREAM STRING)
(MKSTRING STRING])
(FUNCTION MKSTRING)
NIL NIL (FUNCTION MKSTRING])
(\CREATE.THROUGH16.EXTERNALFORMAT
[LAMBDA NIL (* ; "Edited 9-Feb-2026 15:47 by rmk")
(* ; "Edited 5-Feb-2026 13:12 by rmk")
(* ; "Edited 24-Jul-2022 08:08 by rmk")
(* ; "Edited 23-Jun-2021 13:34 by rmk:")
(* ;;; "Create the :THROUGH external format. EOL is adjusted so that the .EOLC callers will not do any conversion.")
(MAKE-EXTERNALFORMAT :THROUGH16 [FUNCTION (LAMBDA (STREAM COUNTP)
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 2))
(\WIN STREAM]
[FUNCTION (LAMBDA (STREAM NOERRORFLG)
(LET (BYTE1 BYTE2)
(CL:WHEN (SETQ BYTE1 (\PEEKBIN STREAM NOERRORFLG))
(\BIN STREAM)
(SETQ BYTE2 (\PEEKBIN STREAM NOERRORFLG))
(\BACKFILEPTR STREAM)
(CL:WHEN BYTE2
(LOGOR (LLSH BYTE1 8)
BYTE2)))]
[FUNCTION (LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:")
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN (\BACKFILEPTR STREAM)
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
(CL:WHEN (\BACKFILEPTR STREAM)
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -2))
T))]
[FUNCTION (LAMBDA (OUTSTREAM CHARCODE)
(\WOUT OUTSTREAM CHARCODE]
NIL
(CL:IF (EQ (CHARCODE CR)
(CHARCODE EOL))
CR.EOLC
LF.EOLC)
NIL
(FUNCTION MKSTRING)
NIL NIL (FUNCTION MKSTRING])
(\THROUGHIN
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:")
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:")
(* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.")
@@ -725,14 +859,14 @@
(\BIN STREAM])
(\THROUGHBACKCCODE
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:")
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:")
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN (\BACKFILEPTR STREAM)
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
T)])
(\THROUGHOUTCHARFN
[LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm")
[LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm")
(* ;;; "Encoder for THROUGH format.")
@@ -745,15 +879,19 @@
(DECLARE%: DONTEVAL@LOAD DOCOPY
(\CREATE.THROUGH.EXTERNALFORMAT)
(\CREATE.THROUGH16.EXTERNALFORMAT)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (6706 14360 (\EXTERNALFORMAT 6716 . 11315) (MAKE-EXTERNALFORMAT 11317 . 13887) (
\EXTERNALFORMAT.DEFPRINT 13889 . 14358)) (14361 17402 (\INSTALL.EXTERNALFORMAT 14371 . 15820) (
\REMOVE.EXTERNALFORMAT 15822 . 16653) (FIND-FORMAT 16655 . 17400)) (17403 17815 (SYSTEM-EXTERNALFORMAT
17413 . 17813)) (18164 34141 (\OUTCHAR 18174 . 19391) (\INCCODE 19393 . 20546) (\BACKCCODE 20548 .
22227) (\BACKCCODE.EOLC 22229 . 24419) (\PEEKCCODE 24421 . 24746) (\PEEKCCODE.EOLC 24748 . 25127) (
\INCCODE.EOLC 25129 . 26928) (\FORMATBYTESTREAM 26930 . 29374) (\FORMATBYTESTRING 29376 . 31076) (
\CHECKEOLC.CRLF 31078 . 34139)) (35423 37659 (\NULLDEVICE 35433 . 37335) (\NULL.OPENFILE 37337 . 37657
)) (37799 39626 (\CREATE.THROUGH.EXTERNALFORMAT 37809 . 38595) (\THROUGHIN 38597 . 39017) (
\THROUGHBACKCCODE 39019 . 39286) (\THROUGHOUTCHARFN 39288 . 39624)))))
(FILEMAP (NIL (7446 15343 (\EXTERNALFORMAT 7456 . 12055) (MAKE-EXTERNALFORMAT 12057 . 14870) (
\EXTERNALFORMAT.DEFPRINT 14872 . 15341)) (15344 18385 (\INSTALL.EXTERNALFORMAT 15354 . 16803) (
\REMOVE.EXTERNALFORMAT 16805 . 17636) (FIND-FORMAT 17638 . 18383)) (18628 20078 (SYSTEM-EXTERNALFORMAT
18638 . 19586) (MTOSYSSTRING 19588 . 19785) (SYSTOMSTRING 19787 . 20076)) (20442 34717 (\OUTCHAR
20452 . 21669) (\INCCODE 21671 . 22824) (\BACKCCODE 22826 . 24505) (\BACKCCODE.EOLC 24507 . 26697) (
\PEEKCCODE 26699 . 27024) (\PEEKCCODE.EOLC 27026 . 27405) (\INCCODE.EOLC 27407 . 29206) (
\FORMATBYTESTREAM 29208 . 31652) (\CHECKEOLC.CRLF 31654 . 34715)) (34718 38634 (MCCSTOFORMATBYTES
34728 . 37127) (FORMATBYTESTOMCCS 37129 . 38632)) (40045 42281 (\NULLDEVICE 40055 . 41957) (
\NULL.OPENFILE 41959 . 42279)) (42371 47286 (\CREATE.THROUGH.EXTERNALFORMAT 42381 . 44050) (
\CREATE.THROUGH16.EXTERNALFORMAT 44052 . 46243) (\THROUGHIN 46245 . 46669) (\THROUGHBACKCCODE 46671 .
46942) (\THROUGHOUTCHARFN 46944 . 47284)))))
STOP

BIN
sources/EXTERNALFORMAT.LCOM
View File

Binary file not shown.

192
sources/FILEIO
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Sep-2025 08:19:06" {WMEDLEY}<sources>FILEIO.;141 166968
(FILECREATED " 6-Feb-2026 23:22:00" {WMEDLEY}<sources>FILEIO.;142 166519
:EDIT-BY rmk
:CHANGES-TO (FNS COPYFILE COPYCHARS)
:CHANGES-TO (FNS DIRECTORYNAME)
:PREVIOUS-DATE "24-Apr-2025 22:16:47"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>FILEIO.;139)
:PREVIOUS-DATE "12-Sep-2025 08:19:06" {WMEDLEY}<sources>FILEIO.;141)
(PRETTYCOMPRINT FILEIOCOMS)
@@ -1986,68 +1985,63 @@ update the map")
\CONNECTED.DIRECTORY])
(DIRECTORYNAME
[LAMBDA (DIRNAME STRPTR CREATE?) (* ; "Edited 20-May-92 11:08 by jds")
[LAMBDA (DIRNAME STRPTR CREATE?) (* ; "Edited 6-Feb-2026 23:19 by rmk")
(* ; "Edited 20-May-92 11:08 by jds")
(* ;; "Returns connected directory name")
(* ;; "Returns connected directory name")
(AND (CL:PATHNAMEP DIRNAME)
(SETQ DIRNAME (CL:NAMESTRING DIRNAME)))
(SELECTQ (SYSTEMTYPE)
(VAX (GETDIRNAME))
(D (DECLARE (GLOBALVARS LOGINHOST/DIR))
[PROG (DN FDEV)
[SELECTQ DIRNAME
(T (* ; "Connected host/dir")
(SETQ DN \CONNECTED.DIRECTORY))
(NIL (SETQ DN (OR LOGINHOST/DIR '{DSK})))
(COND
[(AND [SETQ FDEV
(LET [(HOST (FILENAMEFIELD DIRNAME 'HOST]
(SELCHARQ (NTHCHARCODE DIRNAME 1)
(> (* ;
 "Remove leading > from a subdirectory spec.")
(SETQ DIRNAME (SUBSTRING DIRNAME 2)))
NIL)
(\GETDEVICEFROMHOSTNAME
(OR HOST (FILENAMEFIELD [SELCHARQ (NTHCHARCODE DIRNAME 1)
((< /)
(* ; "Whole directory, use it all.")
(SETQ DIRNAME
(PACKFILENAME.STRING
'DIRECTORY DIRNAME
'BODY \CONNECTED.DIRECTORY)))
(SELCHARQ (NTHCHARCODE DIRNAME
(NCHARS DIRNAME))
((> /)
(* ;
 "Remove any trailing > or / from a subdirectory spec.")
(SETQ DIRNAME
(PACKFILENAME.STRING
'SUBDIRECTORY
(SUBSTRING DIRNAME 1 -2
)
'DIRECTORY
\CONNECTED.DIRECTORY)))
(SETQ DIRNAME
(PACKFILENAME.STRING
'SUBDIRECTORY DIRNAME
'DIRECTORY
\CONNECTED.DIRECTORY]
'HOST]
(SETQ DN (FDEVOP 'DIRECTORYNAMEP FDEV DIRNAME FDEV CREATE?)))
(COND
((EQ DN T)
(SETQ DN (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME)
of FDEV)
'DIRECTORY DIRNAME]
(T (RETURN]
(RETURN (COND
((NOT STRPTR)
(MKSTRING DN))
((EQ STRPTR T)
(MKATOM DN))
(T (MKSTRING DN])
(HELP])
(DECLARE (GLOBALVARS LOGINHOST/DIR))
(CL:WHEN (CL:PATHNAMEP DIRNAME)
(SETQ DIRNAME (CL:NAMESTRING DIRNAME)))
(PROG (DN FDEV)
[SELECTQ DIRNAME
(T (* ; "Connected host/dir")
(SETQ DN \CONNECTED.DIRECTORY))
(NIL (SETQ DN (OR LOGINHOST/DIR '{DSK})))
(COND
[(AND [SETQ FDEV
(LET [(HOST (FILENAMEFIELD DIRNAME 'HOST]
(SELCHARQ (NTHCHARCODE DIRNAME 1)
(> (* ;
 "Remove leading > from a subdirectory spec.")
(SETQ DIRNAME (SUBSTRING DIRNAME 2)))
NIL)
(\GETDEVICEFROMHOSTNAME
(OR HOST (FILENAMEFIELD [SELCHARQ (NTHCHARCODE DIRNAME 1)
((< /)
(* ; "Whole directory, use it all.")
(SETQ DIRNAME (PACKFILENAME.STRING
'DIRECTORY DIRNAME
'BODY
\CONNECTED.DIRECTORY)))
(SELCHARQ (NTHCHARCODE DIRNAME
(NCHARS DIRNAME))
((> /)
(* ;
 "Remove any trailing > or / from a subdirectory spec.")
(SETQ DIRNAME
(PACKFILENAME.STRING
'SUBDIRECTORY
(SUBSTRING DIRNAME 1 -2)
'DIRECTORY
\CONNECTED.DIRECTORY)))
(SETQ DIRNAME (PACKFILENAME.STRING
'SUBDIRECTORY DIRNAME
'DIRECTORY
\CONNECTED.DIRECTORY]
'HOST]
(SETQ DN (FDEVOP 'DIRECTORYNAMEP FDEV DIRNAME FDEV CREATE?)))
(COND
((EQ DN T)
(SETQ DN (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME) of FDEV)
'DIRECTORY DIRNAME]
(T (RETURN]
(RETURN (COND
((NOT STRPTR)
(MKSTRING DN))
((EQ STRPTR T)
(MKATOM DN))
(T (MKSTRING DN])
(DIRECTORYNAMEP
[LAMBDA (DIRNAME HOSTNAME) (* bvm%: "18-Oct-85 14:38")
@@ -3167,39 +3161,39 @@ update the map")
(ADDTOVAR LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (27752 31868 (STREAMPROP 27762 . 28196) (GETSTREAMPROP 28198 . 28947) (PUTSTREAMPROP
28949 . 31716) (STREAMP 31718 . 31866)) (31911 35290 (\DEFPRINT.BY.NAME 31921 . 33073) (
\STREAM.DEFPRINT 33075 . 34983) (\FDEV.DEFPRINT 34985 . 35288)) (35548 40589 (\GETACCESS 35558 . 36012
) (\SETACCESS 36014 . 40587)) (60815 66784 (\DEFINEDEVICE 60825 . 63141) (\GETDEVICEFROMNAME 63143 .
63616) (\GETDEVICEFROMHOSTNAME 63618 . 64662) (\REMOVEDEVICE 64664 . 65787) (\REMOVEDEVICE.NAMES 65789
. 66782)) (66824 94555 (\CLOSEFILE 66834 . 67659) (\DELETEFILE 67661 . 67955) (\DEVICEEVENT 67957 .
69727) (\GENERATEFILES 69729 . 70676) (\GENERATENEXTFILE 70678 . 71329) (\GENERATEFILEINFO 71331 .
71792) (\GETFILENAME 71794 . 72183) (\GENERIC.OUTFILEP 72185 . 72655) (\OPENFILE 72657 . 75235) (
\DO.PARAMS.AT.OPEN 75237 . 79433) (\RENAMEFILE 79435 . 80391) (\REVALIDATEFILE 80393 . 82995) (
\PAGED.REVALIDATEFILELST 82997 . 84555) (\PAGED.REVALIDATEFILES 84557 . 86276) (\PAGED.REVALIDATEFILE
86278 . 88561) (\BUFFERED.REVALIDATEFILE 88563 . 90849) (\BUFFERED.REVALIDATEFILELST 90851 . 92035) (
\PRINT-REVALIDATION-RESULT 92037 . 92879) (\TRUNCATEFILE 92881 . 93272) (\FILE-CONFLICT 93274 . 94553)
) (94591 99254 (\GENERATENOFILES 94601 . 96697) (\NULLFILEGENERATOR 96699 . 96943) (\NOFILESNEXTFILEFN
96945 . 98936) (\NOFILESINFOFN 98938 . 99252)) (99373 101281 (\FILE.NOT.OPEN 99383 . 99896) (
\FILE.WONT.OPEN 99898 . 100226) (\ILLEGAL.DEVICEOP 100228 . 100510) (\IS.NOT.RANDACCESSP 100512 .
100958) (\STREAM.NOT.OPEN 100960 . 101279)) (101416 103714 (\FDEVINSTANCE 101426 . 103712)) (104916
112290 (CNDIR 104926 . 106231) (DIRECTORYNAME 106233 . 110416) (DIRECTORYNAMEP 110418 . 111034) (
HOSTNAMEP 111036 . 111843) (\ADD.CONNECTED.DIR 111845 . 112288)) (112335 141282 (\BACKFILEPTR 112345
. 112533) (\BACKPEEKBIN 112535 . 112896) (\BACKBIN 112898 . 113249) (BIN 113251 . 113468) (\BIN
113470 . 113747) (\BINS 113749 . 114035) (BOUT 114037 . 114399) (\BOUT 114401 . 114716) (\BOUTS 114718
. 115029) (COPYBYTES 115031 . 118363) (COPYCHARS 118365 . 122163) (COPYFILE 122165 . 123525) (
\COPYOPENFILE 123527 . 126726) (\INFER.FILE.TYPE 126728 . 127682) (EOFP 127684 . 127981) (FORCEOUTPUT
127983 . 128230) (\FLUSH.OPEN.STREAMS 128232 . 128588) (CHARSET 128590 . 129949) (ACCESS-CHARSET
129951 . 130588) (GETEOFPTR 130590 . 130840) (GETFILEINFO 130842 . 134035) (\TYPE.FROM.FILETYPE 134037
. 134507) (\FILETYPE.FROM.TYPE 134509 . 134688) (GETFILEPTR 134690 . 134942) (SETFILEINFO 134944 .
139181) (SETFILEPTR 139183 . 140902) (BOUT16 140904 . 141089) (BIN16 141091 . 141280)) (141385 148565
(\GENERIC.BINS 141395 . 141675) (\GENERIC.BOUTS 141677 . 141942) (\GENERIC.RENAMEFILE 141944 . 144192)
(\GENERIC.OPENP 144194 . 145509) (\GENERIC.READP 145511 . 146663) (\GENERIC.CHARSET 146665 . 148563))
(148566 148905 (\MAP-OPEN-STREAMS 148576 . 148903)) (150760 152840 (\EOF.ACTION 150770 . 151021) (
\EOSERROR 151023 . 151216) (\GETEOFPTR 151218 . 151400) (\INCFILEPTR 151402 . 151752) (\PEEKBIN 151754
. 151945) (\SETCLOSEDFILELENGTH 151947 . 152281) (\SETEOFPTR 152283 . 152471) (\SETFILEPTR 152473 .
152838)) (152841 153383 (\FIXPOUT 152851 . 153151) (\FIXPIN 153153 . 153381)) (153384 153950 (\BOUTEOL
153394 . 153948)) (156846 166710 (\BUFFERED.BIN 156856 . 157708) (\BUFFERED.PEEKBIN 157710 . 158492)
(\BUFFERED.BOUT 158494 . 159354) (\BUFFERED.BINS 159356 . 163041) (\BUFFERED.BOUTS 163043 . 164844) (
\BUFFERED.COPYBYTES 164846 . 166708)))))
(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)))))
STOP

BIN
sources/FILEIO.LCOM
View File

Binary file not shown.

1485
sources/IOCHAR
View File

File diff suppressed because it is too large Load Diff

BIN
sources/IOCHAR.LCOM
View File

Binary file not shown.

140
sources/LLSUBRS
View File

@@ -1,15 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "13-Sep-2021 17:12:03" {DSK}<Users>briggs>Projects>medley>sources>LLSUBRS.;8 27017
changes to%: (VARS \INITSUBRS)
(FNS WRITECALLSUBRS)
(FILECREATED " 5-Feb-2026 23:25:59" {WMEDLEY}<sources>LLSUBRS.;18 26279
previous date%: "13-Sep-2021 16:07:08" {DSK}<VAR>TMP>LLSUBRS.;1)
:EDIT-BY rmk
:CHANGES-TO (FNS UNIX-GETENV UNIX-USERNAME UNIX-FULLNAME UNIX-GETPARM)
:PREVIOUS-DATE " 5-Feb-2026 18:13:25" {WMEDLEY}<sources>LLSUBRS.;11)
(* ; "
Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT LLSUBRSCOMS)
@@ -94,9 +92,9 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
,@ARGS])
(DEFOPTIMIZER MISCN (NAME &REST ARGS)
`((OPCODES MISCN ,(MISCN-NUMBER NAME)
,(LENGTH ARGS))
,@ARGS))
`((OPCODES MISCN ,(MISCN-NUMBER NAME)
,(LENGTH ARGS))
,@ARGS))
(DEFINEQ
(MISCN-NUMBER
@@ -190,25 +188,15 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
(SETQ \MISCN-TABLE BASE])
)
(PUTPROPS MISCN ARGNAMES (NAME &REST ARGS))
(PUTPROPS MISCN ARGNAMES ("NAME" &REST "ARGS"))
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD MISCN-UFN-SPEC (
(* ;;
 "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.")
NAME (* ;
 "Name of the MISCN, for the MISCN macro's use.")
INDEX (* ; "Sub-opcode index.")
UFN-NAME (* ; "Name of the UFN")
MVS (* ;
 "T if the UFN can returnmultiple values. If this is NIL, MVs WILL NOT BE PRESERVED.")
))
(RECORD MISCN-UFN-SPEC (NAME INDEX UFN-NAME MVS))
(BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG)
(NIL BITS 3)
(MISCN-UFN POINTER)))
(NIL BITS 3)
(MISCN-UFN POINTER)))
)
)
@@ -218,7 +206,7 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN)
(SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))
(SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))
(* "END EXPORTED DEFINITIONS")
@@ -233,7 +221,7 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
(* ;; "Make Sure \USER-SUBR-TABLE is made")
(IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE)
\USER-SUBR-TABLE))
\USER-SUBR-TABLE))
THEN (\INIT-USER-SUBR-TABLE))
(* ;; "See if the Name is already defined")
@@ -450,9 +438,9 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
,@ARGS])
(DEFOPTIMIZER SUBRCALL (NAME &REST ARGS)
`((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
,(LENGTH ARGS))
,@ARGS))
`((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
,(LENGTH ARGS))
,@ARGS))
(DEFINEQ
(SUBRNUMBER
@@ -612,52 +600,51 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
else NIL])
(UNIX-USERNAME
[LAMBDA NIL (* ; "Edited 1-Aug-88 23:22 by masinter")
(if (EQ \MACHINETYPE \MAIKO)
then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING)
then (CONCAT (SUBSTRING UNIXSTRING 1
(CL:POSITION #\Null UNIXSTRING
])
[LAMBDA NIL (* ; "Edited 5-Feb-2026 23:24 by rmk")
(* ; "Edited 1-Aug-88 23:22 by masinter")
(WITH-RESOURCE UNIXSTRING (CL:WHEN (SUBRCALL UNIX-USERNAME UNIXSTRING)
(SYSTOMSTRING (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null
UNIXSTRING))))])
(UNIX-FULLNAME
[LAMBDA NIL (* ; "Edited 18-Jul-88 03:47 by masinter")
(if (EQ \MACHINETYPE \MAIKO)
then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING)
then (CONCAT (SUBSTRING UNIXSTRING 1
(CL:POSITION #\Null
UNIXSTRING])
[LAMBDA NIL (* ; "Edited 5-Feb-2026 23:24 by rmk")
(* ; "Edited 18-Jul-88 03:47 by masinter")
(WITH-RESOURCES UNIXSTRING (CL:WHEN (SUBRCALL UNIX-FULLNAME UNIXSTRING)
(SYSTOMSTRING (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null
UNIXSTRING))))])
(UNIX-GETENV
[LAMBDA (NAME) (* ; "Edited 21-Feb-2021 21:09 by larry")
(WITH-RESOURCES
UNIXSTRING
(LET ((X UNIXSTRING))
(if (SUBRCALL UNIX-GETENV (MKSTRING NAME)
X)
then (CONCAT (SUBSTRING X 1 (for I from 1
do (if (FMEMB (NTHCHARCODE X I)
'(0 NIL))
then (RETURN (SUB1 I])
[LAMBDA (NAME) (* ; "Edited 5-Feb-2026 23:25 by rmk")
(* ; "Edited 31-Jan-2026 22:28 by rmk")
(* ; "Edited 21-Feb-2021 21:09 by larry")
(WITH-RESOURCES UNIXSTRING
(CL:WHEN (SUBRCALL UNIX-GETENV (MTOSYSSTRING NAME)
UNIXSTRING)
[SYSTOMSTRING (SUBSTRING UNIXSTRING 1
(for I from 1
do (if (FMEMB (NTHCHARCODE UNIXSTRING I)
'(0 NIL))
then (RETURN (SUB1 I])])
(UNIX-GETPARM
[LAMBDA (NAME) (* ; "Edited 27-Feb-91 17:11 by nm")
[LAMBDA (NAME) (* ; "Edited 5-Feb-2026 23:21 by rmk")
(* ; "Edited 27-Feb-91 17:11 by nm")
(* ;; "Read information from the C emulator. Usually gets info about configuration of the machine we're running on.")
(* ;;
"Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.")
 "Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.")
(* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.")
(if (EQ \MACHINETYPE \MAIKO)
then (LET (LEN)
(WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME)
UNIXSTRING))
(COND
[(SMALLP LEN)
(if (> LEN 0)
then (CONCAT (SUBSTRING UNIXSTRING 1 LEN]
(LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING])
(LET (LEN)
(WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MTOSYSSTRING NAME)
UNIXSTRING))
(COND
[(SMALLP LEN)
(if (> LEN 0)
then (SYSTOMSTRING (SUBSTRING UNIXSTRING 1 LEN]
(LEN (SYSTOMSTRING (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING])
)
(PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH))
@@ -684,20 +671,19 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
(PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR))
(PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE)
(PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992
2021))
(PUTPROPS LLSUBRS FILETYPE :FAKE-COMPILE-FILE)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3639 8383 (MISCN-NUMBER 3649 . 3865) (\MISCN.UFN 3867 . 6124) (\UNDEFINED-MISCN-UFN
6126 . 6442) (MISCN-COLLECT 6444 . 6661) (\GET-MY-BF 6663 . 6875) (\INIT-MISCN-TABLE 6877 . 8381)) (
9767 11056 (ADD-USER-SUBR 9767 . 11056)) (11057 12808 (\USER-SUBR-UFN 11067 . 11642) (
\INIT-USER-SUBR-TABLE 11644 . 12109) (\UNDEFINED-USER-SUBR-UFN 12111 . 12454) (USER-SUBR-NUMBER 12456
. 12678) (EQ-TO-CAR 12680 . 12741) (EQ-TO-CADR 12743 . 12806)) (17091 17740 (SUBRNUMBER 17101 . 17738
)) (17801 20104 (WRITECALLSUBRS 17811 . 19347) (FIX-SUBR-NAME 19349 . 20102)) (20313 26217 (
\MOREVMEMFILE 20323 . 20488) (\WRITEMAP 20490 . 20650) (\COPYSYS0SUBR 20652 . 20812) (\PUPLEVEL1STATE
20814 . 20978) (SHOWDISPLAY 20980 . 21269) (SETSCREENCOLOR 21271 . 21434) (\WRITERAWPBI 21436 . 21594)
(\READRAWPBI 21596 . 21748) (RAID 21750 . 21905) (\LISPFINISH 21907 . 22065) (\GETPACKETBUFFER 22067
. 22229) (\GATHERSTATS 22231 . 22389) (\DSPRATE 22391 . 22658) (DSPBOUT 22660 . 22814) (DISKPARTITION
22816 . 23111) (\CHECKBCPLPASSWORD 23113 . 23292) (SUSPEND-LISP 23294 . 23552) (UNIX-USERNAME 23554
. 24076) (UNIX-FULLNAME 24078 . 24604) (UNIX-GETENV 24606 . 25203) (UNIX-GETPARM 25205 . 26215)))))
(FILEMAP (NIL (2955 3362 (MISCN 2955 . 3362)) (3544 8288 (MISCN-NUMBER 3554 . 3770) (\MISCN.UFN 3772
. 6029) (\UNDEFINED-MISCN-UFN 6031 . 6347) (MISCN-COLLECT 6349 . 6566) (\GET-MY-BF 6568 . 6780) (
\INIT-MISCN-TABLE 6782 . 8286)) (8844 8979 (USER-SUBR 8844 . 8979)) (8981 10266 (ADD-USER-SUBR 8981 .
10266)) (10267 12018 (\USER-SUBR-UFN 10277 . 10852) (\INIT-USER-SUBR-TABLE 10854 . 11319) (
\UNDEFINED-USER-SUBR-UFN 11321 . 11664) (USER-SUBR-NUMBER 11666 . 11888) (EQ-TO-CAR 11890 . 11951) (
EQ-TO-CADR 11953 . 12016)) (15683 16094 (SUBRCALL 15683 . 16094)) (16289 16938 (SUBRNUMBER 16299 .
16936)) (16999 19302 (WRITECALLSUBRS 17009 . 18545) (FIX-SUBR-NAME 18547 . 19300)) (19511 25586 (
\MOREVMEMFILE 19521 . 19686) (\WRITEMAP 19688 . 19848) (\COPYSYS0SUBR 19850 . 20010) (\PUPLEVEL1STATE
20012 . 20176) (SHOWDISPLAY 20178 . 20467) (SETSCREENCOLOR 20469 . 20632) (\WRITERAWPBI 20634 . 20792)
(\READRAWPBI 20794 . 20946) (RAID 20948 . 21103) (\LISPFINISH 21105 . 21263) (\GETPACKETBUFFER 21265
. 21427) (\GATHERSTATS 21429 . 21587) (\DSPRATE 21589 . 21856) (DSPBOUT 21858 . 22012) (DISKPARTITION
22014 . 22309) (\CHECKBCPLPASSWORD 22311 . 22490) (SUSPEND-LISP 22492 . 22750) (UNIX-USERNAME 22752
. 23256) (UNIX-FULLNAME 23258 . 23765) (UNIX-GETENV 23767 . 24583) (UNIX-GETPARM 24585 . 25584)))))
STOP

BIN
sources/LLSUBRS.LCOM
View File

Binary file not shown.

265
sources/MCCS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Oct-2025 08:50:00" {WMEDLEY}<sources>MCCS.;155 57020
(FILECREATED " 5-Feb-2026 15:58:32" {WMEDLEY}<sources>MCCS.;163 65441
:EDIT-BY rmk
:CHANGES-TO (VARS MCCSCOMS)
:CHANGES-TO (FNS \DUMMY-UTF8-FORMAT \CREATE.XCCS.EXTERNALFORMAT)
:PREVIOUS-DATE "15-Oct-2025 18:31:01" {WMEDLEY}<sources>MCCS.;154)
:PREVIOUS-DATE " 5-Feb-2026 12:26:39" {WMEDLEY}<sources>MCCS.;161)
(PRETTYCOMPRINT MCCSCOMS)
@@ -17,14 +17,14 @@
(FNS \MCCSINCCODE \MCCSPEEKCCODE \MCCSOUTCHAR \MCCSBACKCCODE \MCCSFORMATBYTESTREAM
\MCCSCHARSETFN)
(FNS \CREATE.MCCS.EXTERNALFORMAT)
(FNS \CREATE.MCCS.EXTERNALFORMAT \CREATE.XCCS.EXTERNALFORMAT)
(FNS \MCCS.24BITENCODING.ERROR)
(INITVARS (*SIGNAL-MCCS.24BITENCODING.ERROR*))
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (CONSTANTS (\NORUNCODE 255)
(NSCHARSETSHIFT 255))
(MACROS \RUNCODED)))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.MCCS.EXTERNALFORMAT :MCCS)
(\CREATE.MCCS.EXTERNALFORMAT :XCCS)))
(\CREATE.XCCS.EXTERNALFORMAT :XCCS)))
(* ;; "")
@@ -57,7 +57,14 @@
 "Mappings into MCCS: needed for hardcopy and Tedit coercion, e.g. \TEDIT.MCCS.TRANSLATE")
(FNS GACHATOMCODE SYMBOLTOMCODE SIGMATOMCODE ATOMCODE MATHTOMCODE HIPPOTOMCODE
CYRILLICTOMCODE PALATINOTOMCODE])
CYRILLICTOMCODE PALATINOTOMCODE)))
(COMS (* ; "ISO8859/1")
(FNS ISO1TOMCODE MTOISO1CODE \CREATE.ISO1.FORMAT \DUMMY-UTF8-FORMAT)
(FNS ISO1TOMSTRING MTOISO1STRING)
(VARS ISO1TOMCCS)
(GLOBALVARS ISO1TOMCCS)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.ISO1.FORMAT)
(\DUMMY-UTF8-FORMAT])
@@ -291,6 +298,33 @@
(FUNCTION \MCCSFORMATBYTESTREAM)
(OR EOL 'LF)
T NIL NIL (FUNCTION \MCCSCHARSETFN])
(\CREATE.XCCS.EXTERNALFORMAT
[LAMBDA (NAME EOL) (* ; "Edited 5-Feb-2026 15:54 by rmk")
(* ; "Edited 1-Feb-2026 12:22 by rmk")
(* ; "Edited 23-Apr-2025 14:19 by rmk")
(* ; "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. Just like :MCCS except for switch of underscore-circumflex/arrows.")
(MAKE-EXTERNALFORMAT (OR NAME :XCCS)
[FUNCTION (LAMBDA (STREAM COUNTP)
(XTOMCODE (\MCCSINCCODE STREAM COUNTP]
[FUNCTION (LAMBDA (STREAM NOERROR)
(XTOMCODE (\MCCSPEEKCCODE STREAM NOERROR]
[FUNCTION (LAMBDA (STREAM COUNTP)
(XTOMCODE (\MCCSBACKCCODE STREAM COUNTP]
[FUNCTION (LAMBDA (STREAM CHARCODE)
(\MCCSOUTCHAR STREAM (MTOXCODE CHARCODE]
(FUNCTION \MCCSFORMATBYTESTREAM)
(OR EOL 'LF)
T
(FUNCTION MTOXSTRING)
NIL
(FUNCTION \MCCSCHARSETFN)
(FUNCTION XTOMSTRING])
)
(DEFINEQ
@@ -338,7 +372,7 @@
(\CREATE.MCCS.EXTERNALFORMAT :MCCS)
(\CREATE.MCCS.EXTERNALFORMAT :XCCS)
(\CREATE.XCCS.EXTERNALFORMAT :XCCS)
)
@@ -1246,7 +1280,9 @@
(DEFINEQ
(MCCSCODEMAPARRAY
[LAMBDA (MAP) (* ; "Edited 6-Sep-2025 18:26 by rmk")
[LAMBDA (MAP INVERT) (* ; "Edited 5-Feb-2026 11:02 by rmk")
(* ; "Edited 2-Feb-2026 23:11 by rmk")
(* ; "Edited 6-Sep-2025 18:26 by rmk")
(* ; "Edited 31-Aug-2025 16:15 by rmk")
(* ; "Edited 7-Aug-2025 08:55 by rmk")
(* ; "Edited 2-Jun-2025 11:45 by rmk")
@@ -1260,19 +1296,28 @@
(XCCS (SETQ MAP (APPEND MTOXCODEMAP ALTOTEXT2MCCS)))
(MCCS (SETQ MAP ALTOTEXT2MCCS))
NIL)
(LET ((TABLE (ARRAY (ADD1 \MAXTHINCHAR)
'WORD 0 0)))
(for I from 0 to \MAXTHINCHAR do (SETA TABLE I I))
(LET ((ARRAY (ARRAY (ADD1 \MAXTHINCHAR)
'WORD 0 0))
HARRAY)
(for I from 0 to \MAXTHINCHAR do (SETA ARRAY I I)) (* ; "Default")
[for PAIR FROMCODE in MAP when (LISTP PAIR) unless (EQ '* (CAR PAIR))
when (SETQ FROMCODE (CL:IF (CHARCODEP (CAR PAIR))
(CAR PAIR)
when (SETQ FROMCODE (OR (CHARCODEP (CAR PAIR))
(CHARCODE.DECODE (CAR PAIR)
T))) do (SETA TABLE FROMCODE (CL:IF (CHARCODEP
(CADR PAIR))
(CADR PAIR)
T))) do (SETA ARRAY FROMCODE (OR (CHARCODEP (CADR PAIR))
(CHARCODE.DECODE
(CADR PAIR)))]
TABLE])
(CADR PAIR]
(CL:WHEN INVERT
(SETQ HARRAY (HASHARRAY 20))
(for I from 0 to \MAXTHINCHAR do (PUTHASH I I HARRAY))
(for PAIR FROMCODE in MAP when (LISTP PAIR) unless (EQ '* (CAR PAIR))
do (PUTHASH (OR (CHARCODEP (CADR PAIR))
(CHARCODE.DECODE (CADR PAIR)))
(OR (CHARCODEP (CAR PAIR))
(CHARCODE.DECODE (CAR PAIR)))
HARRAY)))
(CL:IF HARRAY
(LIST ARRAY HARRAY)
ARRAY)])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
@@ -1496,16 +1541,178 @@
MCODE)))
PCODE])
)
(* ; "ISO8859/1")
(DEFINEQ
(ISO1TOMCODE
[LAMBDA (ICODE) (* ; "Edited 5-Feb-2026 12:09 by rmk")
(* ; "Edited 2-Feb-2026 23:14 by rmk")
(* ; "Edited 7-Sep-2025 22:39 by rmk")
(* ; "Edited 3-Sep-2025 10:21 by rmk")
(* ; "Edited 7-Aug-2025 09:37 by rmk")
(* ;; "ISO codes are 8bit, MCODES maybe not. Caller shouldn't pass a fat code.")
(OR [CAR (find PAIR in ISO1TOMCCS suchthat (EQ ICODE (CADR PAIR]
ICODE])
(MTOISO1CODE
[LAMBDA (MCODE) (* ; "Edited 5-Feb-2026 12:26 by rmk")
(* ; "Edited 2-Feb-2026 22:58 by rmk")
(OR (CADR (ASSOC MCODE ISO1TOMCCS))
MCODE])
(\CREATE.ISO1.FORMAT
[LAMBDA NIL (* ; "Edited 5-Feb-2026 10:42 by rmk")
(* ; "Edited 2-Feb-2026 23:37 by rmk")
(* ; "Edited 1-Feb-2026 11:18 by rmk")
(* ; "Edited 5-Aug-2021 22:15 by rmk:")
(* ; "Edited 9-Mar-99 17:19 by rmk:")
(* ; "Edited 7-Dec-95 16:24 by ")
(* ; "Edited 7-Dec-95 16:20 by ")
(MAKE-EXTERNALFORMAT :ISO8859/1 [FUNCTION (LAMBDA (STREAM COUNTP)
(ISO1TOMCODE (\THROUGHIN STREAM COUNTP]
[FUNCTION (LAMBDA (STREAM NOERRORFLG)
(ISO1TOMCODE (\PEEKBIN STREAM NOERRORFLG]
(FUNCTION \THROUGHBACKCCODE)
(FUNCTION NILL)
(FUNCTION NILL)
NIL NIL (FUNCTION MTOISO1STRING)
NIL
(FUNCTION NILL)
(FUNCTION ISO1TOMSTRING])
(\DUMMY-UTF8-FORMAT
[LAMBDA NIL (* ; "Edited 5-Feb-2026 15:58 by rmk")
(* ; "Edited 1-Feb-2026 13:16 by rmk")
(* ;; "Works only for 7-bit codes, during the loadup")
(\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT using (FIND-FORMAT :ISO8859/1)
NAME _ :UTF-8])
)
(DEFINEQ
(ISO1TOMSTRING
[LAMBDA (ISTRING DESTRUCTIVE) (* ; "Edited 5-Feb-2026 11:01 by rmk")
(* ; "Edited 2-Feb-2026 23:46 by rmk")
(* ; "Edited 2-Sep-2025 12:14 by rmk")
(* ; "Edited 29-Apr-2025 13:08 by rmk")
(* ;; "Converts ISO8859/1 codes to MCCS codes in MSTRING.")
(for I ICODE (MSTRING _ (CL:IF DESTRUCTIVE
ISTRING
(CONCAT ISTRING))) from 1 while (SETQ ICODE (NTHCHARCODE ISTRING I))
do (RPLCHARCODE MSTRING I (ISO1TOMCODE ICODE)) finally (RETURN MSTRING])
(MTOISO1STRING
[LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 2-Feb-2026 23:47 by rmk")
(* ; "Edited 2-Sep-2025 12:22 by rmk")
(* ; "Edited 29-Apr-2025 13:08 by rmk")
(* ;; "Converts MCCS to ISO8859/1 codes in MSTRING.")
(for I MCODE (ISTRING _ (CL:IF DESTRUCTIVE
MSTRING
(CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I))
do (RPLCHARCODE ISTRING I (MTOISO1CODE MCODE)) finally (RETURN ISTRING])
)
(RPAQQ ISO1TOMCCS
((94 8593)
(95 8592)
(169 8216)
(170 8220)
(172 95)
(173 94)
(174 8594)
(175 8595)
(180 215)
(184 247)
(185 8217)
(186 8221)
(193 768)
(194 769)
(195 770)
(196 771)
(197 772)
(198 774)
(199 775)
(200 776)
(202 778)
(203 807)
(204 818)
(205 779)
(206 808)
(207 780)
(208 8213)
(209 185)
(210 174)
(211 169)
(212 8482)
(213 9834)
(220 8539)
(221 8540)
(222 8541)
(223 8542)
(224 8486)
(225 198)
(226 208)
(227 170)
(228 294)
(229 567)
(230 306)
(231 319)
(232 321)
(233 216)
(234 338)
(235 186)
(236 222)
(237 358)
(238 330)
(239 329)
(240 312)
(241 230)
(242 273)
(243 240)
(244 295)
(245 305)
(246 307)
(247 320)
(248 322)
(249 248)
(250 339)
(251 223)
(252 254)
(253 359)
(254 331)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS ISO1TOMCCS)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(\CREATE.ISO1.FORMAT)
(\DUMMY-UTF8-FORMAT)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2853 14424 (\MCCSINCCODE 2863 . 5951) (\MCCSPEEKCCODE 5953 . 8840) (\MCCSOUTCHAR 8842
. 10941) (\MCCSBACKCCODE 10943 . 12487) (\MCCSFORMATBYTESTREAM 12489 . 13219) (\MCCSCHARSETFN 13221
. 14422)) (14425 15307 (\CREATE.MCCS.EXTERNALFORMAT 14435 . 15305)) (15308 16285 (
\MCCS.24BITENCODING.ERROR 15318 . 16283)) (17661 20299 (MTOXCODE 17671 . 18468) (XTOMCODE 18470 .
19127) (XTOMSTRING 19129 . 19714) (MTOXSTRING 19716 . 20297)) (20300 21960 (MTOX$CODE 20310 . 21042) (
X$TOMCODE 21044 . 21958)) (21961 22601 (KANJICHARSETP 21971 . 22227) (CHINESECHARSETP 22229 . 22599))
(43169 45043 (MCCSCODEMAPARRAY 43179 . 45041)) (45659 52140 (MCCSMAPFN 45669 . 47036) (MCCSMAPPAIRS
47038 . 51146) (XCCS.CS0.UNDEFINED 51148 . 51777) (XCCSUNDEFINEDPAIRS 51779 . 52138)) (52245 56997 (
GACHATOMCODE 52255 . 52767) (SYMBOLTOMCODE 52769 . 53417) (SIGMATOMCODE 53419 . 54065) (ATOMCODE 54067
. 54599) (MATHTOMCODE 54601 . 55257) (HIPPOTOMCODE 55259 . 55796) (CYRILLICTOMCODE 55798 . 56232) (
PALATINOTOMCODE 56234 . 56995)))))
(FILEMAP (NIL (3345 14916 (\MCCSINCCODE 3355 . 6443) (\MCCSPEEKCCODE 6445 . 9332) (\MCCSOUTCHAR 9334
. 11433) (\MCCSBACKCCODE 11435 . 12979) (\MCCSFORMATBYTESTREAM 12981 . 13711) (\MCCSCHARSETFN 13713
. 14914)) (14917 17368 (\CREATE.MCCS.EXTERNALFORMAT 14927 . 15797) (\CREATE.XCCS.EXTERNALFORMAT 15799
. 17366)) (17369 18346 (\MCCS.24BITENCODING.ERROR 17379 . 18344)) (19722 22360 (MTOXCODE 19732 .
20529) (XTOMCODE 20531 . 21188) (XTOMSTRING 21190 . 21775) (MTOXSTRING 21777 . 22358)) (22361 24021 (
MTOX$CODE 22371 . 23103) (X$TOMCODE 23105 . 24019)) (24022 24662 (KANJICHARSETP 24032 . 24288) (
CHINESECHARSETP 24290 . 24660)) (45230 47719 (MCCSCODEMAPARRAY 45240 . 47717)) (48335 54816 (MCCSMAPFN
48345 . 49712) (MCCSMAPPAIRS 49714 . 53822) (XCCS.CS0.UNDEFINED 53824 . 54453) (XCCSUNDEFINEDPAIRS
54455 . 54814)) (54921 59673 (GACHATOMCODE 54931 . 55443) (SYMBOLTOMCODE 55445 . 56093) (SIGMATOMCODE
56095 . 56741) (ATOMCODE 56743 . 57275) (MATHTOMCODE 57277 . 57933) (HIPPOTOMCODE 57935 . 58472) (
CYRILLICTOMCODE 58474 . 58908) (PALATINOTOMCODE 58910 . 59671)) (59700 62493 (ISO1TOMCODE 59710 .
60459) (MTOISO1CODE 60461 . 60751) (\CREATE.ISO1.FORMAT 60753 . 62018) (\DUMMY-UTF8-FORMAT 62020 .
62491)) (62494 64025 (ISO1TOMSTRING 62504 . 63320) (MTOISO1STRING 63322 . 64023)))))
STOP

BIN
sources/MCCS.LCOM
View File

Binary file not shown.

15
sources/MEDLEYDIR
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Nov-2025 21:51:39" {WMEDLEY}<sources>MEDLEYDIR.;43 15970
(FILECREATED "31-Jan-2026 23:43:06" {WMEDLEY}<sources>MEDLEYDIR.;44 16074
:EDIT-BY rmk
:CHANGES-TO (VARS MEDLEYDIRCOMS)
:CHANGES-TO (FNS MEDLEYDIR)
:PREVIOUS-DATE "26-Nov-2025 17:12:16" {WMEDLEY}<sources>MEDLEYDIR.;42)
:PREVIOUS-DATE "26-Nov-2025 21:51:39" {WMEDLEY}<sources>MEDLEYDIR.;43)
(PRETTYCOMPRINT MEDLEYDIRCOMS)
@@ -139,7 +139,8 @@
NIL])
(MEDLEYDIR
[LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ; "Edited 23-Aug-2025 17:21 by lmm")
[LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ; "Edited 31-Jan-2026 23:42 by rmk")
(* ; "Edited 23-Aug-2025 17:21 by lmm")
(* ; "Edited 18-Aug-2025 11:15 by FGH")
(* ; "Edited 29-Jun-2023 22:48 by rmk")
(* ; "Edited 18-Oct-2022 17:49 by lmm")
@@ -184,7 +185,7 @@
(UNIX-GETENV "HOME")
DIRNAME)))
[(EQUAL DIRNAME "loadups") (* ; "special case for loadups dir")
(OR (DIRECTORYNAME (UNIX-GETENV "MEDLEY_LOADUPS_DIR"))
(OR (DIRECTORYNAME (UNIX-GETENV "MEDLEY¬LOADUPS¬DIR"))
(DIRECTORYNAME (CONCAT (MEDLEYDIR)
"loadups" ">")
NIL OUTPUT)
@@ -284,6 +285,6 @@
(ADDTOVAR GLOBALVARS MEDLEYDIR MEDLEY-INIT-VARS \SAVE.MEDLEYDIR DIRECTORIES SYSOUTCOMMITS)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (5329 13232 (MEDLEY-INIT-VARS 5339 . 8817) (MEDLEYDIR 8819 . 12032) (MEDLEYSUBSTDIR
12034 . 13012) (SET-SYSOUT-COMMIT 13014 . 13230)))))
(FILEMAP (NIL (5324 13336 (MEDLEY-INIT-VARS 5334 . 8812) (MEDLEYDIR 8814 . 12136) (MEDLEYSUBSTDIR
12138 . 13116) (SET-SYSOUT-COMMIT 13118 . 13334)))))
STOP

BIN
sources/MEDLEYDIR.LCOM
View File

Binary file not shown.

36
sources/PACKAGE-STARTUP
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "21-Mar-2024 10:21:14" |{DSK}<home>larry>il>medley>sources>PACKAGE-STARTUP.;9| 36658
(FILECREATED " 8-Feb-2026 11:47:57" |{WMEDLEY}<sources>PACKAGE-STARTUP.;6| 36725
:EDIT-BY "lmm"
:EDIT-BY |rmk|
:CHANGES-TO (VARIABLES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.SHARED)
:CHANGES-TO (FUNCTIONS PACKAGE-ENABLE)
:PREVIOUS-DATE "20-Mar-2024 23:34:56" |{DSK}<home>larry>il>medley>sources>PACKAGE-STARTUP.;8|
)
:PREVIOUS-DATE "21-Mar-2024 10:21:14" |{WMEDLEY}<sources>PACKAGE-STARTUP.;5|)
(PRETTYCOMPRINT PACKAGE-STARTUPCOMS)
@@ -566,7 +565,8 @@
(CONCOCT-SYMBOL I))
T)
(CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*))
(CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*))
(* \; "Edited 8-Feb-2026 11:47 by rmk")
"Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly."
(DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *PACKAGE* *OLD-INTERLISP-READ-ENVIRONMENT*
*PER-EXEC-VARIABLES*))
@@ -594,8 +594,8 @@
(T (PROMPTPRINT "Invalid package, reset to LISP")
(SETQ *PACKAGE* (CL:FIND-PACKAGE "LISP")))))
*PER-EXEC-VARIABLES* :TEST 'CL:EQUAL)
(CL:SETF *DEFAULT-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT
:XCCS))
(CL:SETF *DEFAULT-MAKEFILE-ENVIRONMENT* `(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT
,*DEFAULT-EXTERNALFORMAT*))
(MOVD '\\NEW.READ.SYMBOL '\\READ.SYMBOL)
(MOVD '\\NEW.MKATOM '\\MKATOM)
(CL:SETF *PACKAGE* PACKAGE)
@@ -644,14 +644,14 @@
(PACKAGE-INIT)
)
(DECLARE\: DONTCOPY
(FILEMAP (NIL (3038 3133 (RETURN-FIRST-OF-THREE 3038 . 3133)) (3135 3273 (
ERROR-MISSING-EXTERNAL-SYMBOL 3135 . 3273)) (3880 4848 (CHECK-SYMBOL-NAMESTRING 3880 . 4848)) (4850
8008 (\\NEW.READ.SYMBOL 4850 . 8008)) (8010 9720 (\\NEW.MKATOM 8010 . 9720)) (23549 23631 (
LITATOM.EXISTS 23549 . 23631)) (24311 25317 (NAMESTRING-CONVERSION-CLAUSE 24311 . 25317)) (25319 26574
(CONVERT-LITATOM 25319 . 26574)) (26576 28649 (CONCOCT-SYMBOL 26576 . 28649)) (28651 28945 (
TRANSFER-SYMBOL 28651 . 28945)) (28947 29655 (INTERN-LITATOM 28947 . 29655)) (29657 30336 (
\\LITATOM.EATCHARS 29657 . 30336)) (30338 30615 (PACKAGE-INIT 30338 . 30615)) (30617 31190 (
PACKAGE-CLEAR 30617 . 31190)) (31192 32583 (PACKAGE-MAKE 31192 . 32583)) (32585 33897 (
PACKAGE-HIERARCHY-INIT 32585 . 33897)) (33899 35508 (PACKAGE-ENABLE 33899 . 35508)) (35510 36153 (
PACKAGE-DISABLE 35510 . 36153)) (36200 36226 (ID 36200 . 36226)))))
(FILEMAP (NIL (2977 3072 (RETURN-FIRST-OF-THREE 2977 . 3072)) (3074 3212 (
ERROR-MISSING-EXTERNAL-SYMBOL 3074 . 3212)) (3819 4787 (CHECK-SYMBOL-NAMESTRING 3819 . 4787)) (4789
7947 (\\NEW.READ.SYMBOL 4789 . 7947)) (7949 9659 (\\NEW.MKATOM 7949 . 9659)) (23488 23570 (
LITATOM.EXISTS 23488 . 23570)) (24250 25256 (NAMESTRING-CONVERSION-CLAUSE 24250 . 25256)) (25258 26513
(CONVERT-LITATOM 25258 . 26513)) (26515 28588 (CONCOCT-SYMBOL 26515 . 28588)) (28590 28884 (
TRANSFER-SYMBOL 28590 . 28884)) (28886 29594 (INTERN-LITATOM 28886 . 29594)) (29596 30275 (
\\LITATOM.EATCHARS 29596 . 30275)) (30277 30554 (PACKAGE-INIT 30277 . 30554)) (30556 31129 (
PACKAGE-CLEAR 30556 . 31129)) (31131 32522 (PACKAGE-MAKE 31131 . 32522)) (32524 33836 (
PACKAGE-HIERARCHY-INIT 32524 . 33836)) (33838 35575 (PACKAGE-ENABLE 33838 . 35575)) (35577 36220 (
PACKAGE-DISABLE 35577 . 36220)) (36267 36293 (ID 36267 . 36293)))))
STOP

BIN
sources/PACKAGE-STARTUP.LCOM
View File

Binary file not shown.

317
sources/UFS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Jan-2026 11:06:10" {WMEDLEY}<sources>UFS.;62 91935
(FILECREATED " 6-Feb-2026 23:23:31" {WMEDLEY}<sources>UFS.;68 92871
:EDIT-BY rmk
:CHANGES-TO (VARS UFSCOMS)
:CHANGES-TO (FNS \UFS.NEXTFILEFN \UFSGenerateFiles \UFSDirectoryNameP \UFS.DIRECTORY.NAME)
:PREVIOUS-DATE "27-Oct-2025 11:10:55" {WMEDLEY}<sources>UFS.;61)
:PREVIOUS-DATE " 5-Feb-2026 18:34:38" {WMEDLEY}<sources>UFS.;66)
(PRETTYCOMPRINT UFSCOMS)
@@ -14,11 +14,6 @@
(RPAQQ UFSCOMS
[(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
UFS)
[COMS
(* ;; "For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed.")
(P (MOVD? 'EVQ 'UTF8TOMSTRING)
(MOVD? 'EVQ 'MTOUTF8STRING]
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
DIRECTORY FILEIO))
(INITVARS (\UFS.DEFAULT.EOLC NIL))
@@ -135,17 +130,6 @@
(PUTPROPS UFS FILETYPE :BCOMPL)
(PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10))
(* ;;
"For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed."
)
(MOVD? 'EVQ 'UTF8TOMSTRING)
(MOVD? 'EVQ 'MTOUTF8STRING)
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY
(FILESLOAD (LOADCOMP)
@@ -290,7 +274,8 @@
(DEFINEQ
(\UFSOpenFile
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 16-Oct-2025 08:52 by rmk")
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 08:52 by rmk")
(* ; "Edited 6-Jun-90 12:18 by nm")
(* ;;; "Open a file.")
@@ -355,7 +340,7 @@
(\UFSError CASE.CORRECT.NAME 23 FDEV)))
(SETQ CDATE (CREATECELL \FIXP))
(SETQ BYTESIZE (CREATECELL \FIXP))
[SETQ FILEID (OR (\UFSOpenFile-C (MTOUTF8STRING CASE.CORRECT.FULLFILENAME)
[SETQ FILEID (OR (\UFSOpenFile-C (MTOSYSSTRING CASE.CORRECT.FULLFILENAME)
REC ACC CDATE BYTESIZE ERRNO)
(RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV]
(if (= (IPLUS BYTESIZE 0)
@@ -398,7 +383,8 @@
)
(\UFS.RECOGNIZE.FILE
[LAMBDA (FILENAME RECOG DEV) (* ; "Edited 16-Oct-2025 10:19 by rmk")
[LAMBDA (FILENAME RECOG DEV) (* ; "Edited 5-Feb-2026 18:32 by rmk")
(* ; "Edited 16-Oct-2025 10:19 by rmk")
(* ; "Edited 13-Mar-90 11:19 by nm")
(* ;; "This assumes that input FILENAME is MCCS, returns MCCS")
@@ -410,7 +396,7 @@
(ERRNO (CREATECELL \FIXP))
LEN)
(SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV)
(MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD FILENAME DEV))
(MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD FILENAME DEV))
(SELECTQ RECOG
(OLD RECOG-OLD)
(OLDEST RECOG-OLDEST)
@@ -421,28 +407,28 @@
NAMEAREA ERRNO))
(COND
((FIXP LEN)
(UTF8TOMSTRING (SUBSTRING NAMEAREA 1 LEN)))
(SYSTOMSTRING (SUBSTRING NAMEAREA 1 LEN)))
(T (\UFSError FILENAME ERRNO])])
(\UFS.DIRECTORY.NAME
[LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 15-Oct-2025 16:30 by rmk")
[LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 6-Feb-2026 18:23 by rmk")
(* ; "Edited 15-Oct-2025 16:30 by rmk")
(* ; "Edited 1-Apr-90 23:36 by nm")
(* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"true%" name of the directory in NAMEAREA and returns the length of the name. If such directory does not exist, returns NIL. The canonical directory name does not include the initial directory delimiter and the trail directory delimiter, but the result %"true%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.")
(* ;; "DIRSTRING is MCCS, the true name is not")
(* ;; "DIRSTRING is in system format")
(if (STREQUAL DIRSTRING "<")
then (RPLSTRING NAMEAREA 1 "<")
1
else (WITH.MONITOR (\UFSGetMonitor DEV)
(CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV)
(MTOUTF8STRING DIRSTRING)
NAMEAREA
(CREATECELL \FIXP)))])
DIRSTRING NAMEAREA (CREATECELL \FIXP)))])
(\UFSCloseFile
[LAMBDA (STREAMFILE) (* ; "Edited 16-Oct-2025 13:47 by rmk")
[LAMBDA (STREAMFILE) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 13:47 by rmk")
(* ; "Edited 16-Sep-2023 09:21 by briggs")
(* ; "Edited 30-Mar-90 10:39 by nm")
(* ; "return stream")
@@ -467,7 +453,7 @@
then (* ; "Open for output")
(FDEVOP 'TRUNCATEFILE DEVICE STREAMFILE)
(SETQ CDATE (fetch (UFSSTREAM CDATE) of STREAMFILE)))
(RETURN (if (\UFSCloseFile-C (MTOUTF8STRING UNIXNAME)
(RETURN (if (\UFSCloseFile-C (MTOSYSSTRING UNIXNAME)
(fetch (UFSSTREAM FILEID) of STREAMFILE)
CDATE ERRNO)
then (replace (UFSSTREAM FILEID) of STREAMFILE with NIL)
@@ -482,7 +468,8 @@
)
(\UFSDeleteFile
[LAMBDA (FILENAME DEV) (* ; "Edited 27-Oct-2025 11:10 by rmk")
[LAMBDA (FILENAME DEV) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 27-Oct-2025 11:10 by rmk")
(* ; "Edited 30-Mar-90 10:46 by nm")
(* ; "return deleted file name")
(* ; "if error, return NIL")
@@ -493,14 +480,15 @@
 "file found and not open, so try to delete")
(LET ((ERRNO (CREATECELL \FIXP)))
(COND
((\UFSDeleteFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NAME DEV))
((\UFSDeleteFile-C (MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD NAME DEV))
DEV ERRNO) (* ; "Success")
(\UFS.FULLNAME NAME DEV T))
(T (* ; "Failure")
(\UFSError NAME ERRNO DEV])])
(\UFSRenameFile
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 16-Oct-2025 08:46 by rmk")
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 08:46 by rmk")
(* ; "Edited 18-Dec-2024 12:52 by rmk")
(* ; "Edited 16-Apr-90 13:46 by nm")
(if (NEQ OLD-DEVICE NEW-DEVICE)
@@ -518,10 +506,10 @@
(LET ((NEWUNIXNAME (\UFS.RECOGNIZE.FILE NEW-NAME 'NEW NEW-DEVICE))
(ERRNO (CREATECELL \FIXP)))
(COND
((\UFSRenameFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD
OLDUNIXNAME OLD-DEVICE))
(MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME
NEW-DEVICE))
((\UFSRenameFile-C (MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD OLDUNIXNAME
OLD-DEVICE))
(MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME NEW-DEVICE
))
NEW-DEVICE ERRNO)
(\UFS.FULLNAME NEWUNIXNAME NEW-DEVICE))
(T (if (EQL (IPLUS ERRNO 0)
@@ -543,7 +531,8 @@
)
(\UFSTruncateFile
[LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 16-Oct-2025 08:56 by rmk")
[LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 08:56 by rmk")
(* ; "Edited 22-Aug-90 16:46 by nm")
(* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.")
@@ -581,16 +570,19 @@
(* ;;
 "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.")
(if (\UFSGetFileInfo-C (MTOUTF8STRING (fetch (UFSSTREAM UNIXNAME) of STREAM))
(if (\UFSGetFileInfo-C (MTOSYSSTRING (fetch (UFSSTREAM UNIXNAME) of STREAM))
ATTR-WDATE DT ERRNO)
then (replace (STREAM VALIDATION) of STREAM with DT])
(\UFSDirectoryNameP
[LAMBDA (DIRSPEC DEV) (* ; "Edited 16-Oct-2025 10:23 by rmk")
[LAMBDA (DIRSPEC DEV) (* ; "Edited 6-Feb-2026 23:19 by rmk")
(* ; "Edited 16-Oct-2025 10:23 by rmk")
(* ; "Edited 21-Sep-92 15:27 by jds")
(* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.")
(* ;; "DIRSPEC is in system format")
(LET ([DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC 'DEVICE)
"")
(OR (UNPACKFILENAME.STRING DIRSPEC 'DIRECTORY 'RETURN)
@@ -606,12 +598,13 @@
(COND
(DIRECTORY (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN))
(* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.")
(SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV))
(SETQ LEN (\UFS.DIRECTORY.NAME (MTOSYSSTRING DIRECTORY)
NAMEAREA DEV))
(COND
((FIXP LEN) (* ;
 "LEN holds the length of the %"true%" name of DIRECTORY.")
(UTF8TOMSTRING (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN)
DEV NIL)))
(\UFS.FULLNAME (SYSTOMSTRING (SUBSTRING NAMEAREA 1 LEN))
DEV NIL))
(T NIL)))
(T NIL])
@@ -620,7 +613,8 @@
)
(\UFSGetFileInfo
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 16-Oct-2025 08:49 by rmk")
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 5-Feb-2026 18:32 by rmk")
(* ; "Edited 16-Oct-2025 08:49 by rmk")
(* ; "Edited 30-Mar-90 12:27 by nm")
(* ;;; "Get the value of the attribute for a file.")
@@ -639,7 +633,7 @@
(ERRNO (CREATECELL \FIXP))
BUFFER NAMESIZE)
(if FILENAME
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
then (SETQ FILENAME (MTOSYSSTRING FILENAME))
(SELECTQ ATTRIBUTE
(LENGTH (SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO)
@@ -671,7 +665,7 @@
(AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN))
(if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER
ERRNO))
then (UTF8TOMSTRING (CL:SUBSEQ BUFFER 0 NAMESIZE))
then (SYSTOMSTRING (CL:SUBSEQ BUFFER 0 NAMESIZE))
else (\UFSError FILENAME ERRNO DEVICE)))
(PROTECTION (SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO)
@@ -692,7 +686,8 @@
)
(\UFSSetFileInfo
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 16-Oct-2025 08:51 by rmk")
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 08:51 by rmk")
(* ; "Edited 30-Mar-90 12:31 by nm")
(* ;;; "Get the VALUE of the ATTRIBUTE for a file.")
@@ -711,7 +706,7 @@
(ERRNO (CREATECELL \FIXP))
BUFFER NAMESIZE PATHNAME)
(if FILENAME
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
then (SETQ FILENAME (MTOSYSSTRING FILENAME))
(SELECTQ ATTRIBUTE
(TYPE (\UFSSetFileType FILENAME VALUE))
((CREATIONDATE WRITEDATE)
@@ -735,6 +730,8 @@
(\UFSGenerateFiles
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS)
(* ;; "Edited 6-Feb-2026 22:43 by rmk")
(* ;; "Edited 16-Oct-2025 11:06 by rmk")
(* ;; "Edited 27-Mar-2022 15:55 by rmk: Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults")
@@ -750,8 +747,13 @@
(* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.")
(* ;;
 "All the internals are in system format, individual results must be converted back to MCCS.")
(* ;; "PATTERN is MCCS, is immediately converted to system format")
(WITH.MONITOR (\UFSGetMonitor FDEV)
[PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN))
[PROG* ((PARSED (UNPACKFILENAME.STRING (MTOSYSSTRING PATTERN)))
(DIRECTORY (OR (LISTGET PARSED 'DIRECTORY)
(\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED 'RELATIVEDIRECTORY)
FDEV)
@@ -769,27 +771,26 @@
(DEFAULTVERS (OR (LISTGET PARSED 'VERSION)
DEFAULTVERS)))
(* ;; "All fields are now in the system external format")
(* ;; "rmk: uses the default below, don't want NIL if the pattern includes something else.")
(COND
((STREQUAL DIRECTORY "/")
(SETQ DIRECTORY "<")))
(* ;; "DIRECTORY is MCCS, FILTER is UTF8")
[SETQ FILTER (MTOUTF8STRING (COND
((STREQUAL DIRECTORY "<")
(CONCAT "{" (LISTGET PARSED 'HOST)
"}"
(OR DEVICE "")
"<"
(PACKFILENAME.STRING 'NAME NAME 'EXTENSION
EXTENSION 'VERSION VERSION)))
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY
'HOST
(LISTGET PARSED 'HOST)
'DEVICE DEVICE 'NAME NAME 'EXTENSION
EXTENSION 'VERSION VERSION]
[SETQ FILTER (COND
((STREQUAL DIRECTORY "<")
(CONCAT "{" (LISTGET PARSED 'HOST)
"}"
(OR DEVICE "")
"<"
(PACKFILENAME.STRING 'NAME NAME 'EXTENSION EXTENSION
'VERSION VERSION)))
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET
PARSED
'HOST)
'DEVICE DEVICE 'NAME NAME 'EXTENSION EXTENSION 'VERSION
VERSION]
(SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "")
DIRECTORY)
NAMEAREA FDEV))
@@ -797,7 +798,7 @@
((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case")
(PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory")
(RETURN (\NULLFILEGENERATOR]
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ; "DIRECTORY is now UTF8")
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN))
(* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.")
@@ -808,8 +809,7 @@
(SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO))
(COND
[(< TOTALNUM 0)
(OR (\UFSError (UTF8TOMSTRING DIRECTORY)
ERRNO FDEV)
(OR (\UFSError DIRECTORY ERRNO FDEV)
(RETURN (\NULLFILEGENERATOR]
(T (COND
((ZEROP TOTALNUM)
@@ -819,7 +819,8 @@
(FMEMB 'RESETLST OPTIONS))
(RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID]
(* ;; "Everything in FILEGENOBJ is UTF8")
(* ;;
 "Everything in FILEGENOBJ is in system character encoding (UTF-8?)")
(RETURN (create FILEGENOBJ
NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN)
@@ -842,20 +843,21 @@
CURRENT-DEPTH _ 1
MAX-DEPTH _
FILING.ENUMERATION.DEPTH
FILTER _
(PACKFILENAME.STRING
'NAME
(AND NAME (MTOUTF8STRING
NAME))
'EXTENSION
(AND EXTENSION (
MTOUTF8STRING
EXTENSION))
'VERSION VERSION])])
FILTER _ (
PACKFILENAME.STRING
'NAME NAME
'EXTENSION
EXTENSION
'VERSION VERSION])
])
(\UFS.NEXTFILEFN
[LAMBDA (GENFILESTATE NAMEONLY)
(* ;; "Edited 6-Feb-2026 23:23 by rmk")
(* ;; "Edited 5-Feb-2026 18:32 by rmk")
(* ;; "Edited 16-Oct-2025 16:59 by rmk")
(* ;;
@@ -865,7 +867,7 @@
(* ;; "Given a UFS filesystem generator, return the %"next%" file in line.")
(* ;; "All the fields of the UFSGENFILESTATE are UTF8. FILENAME is MCCS")
(* ;; "All the fields of the UFSGENFILESTATE are in system format (UTF-8?). Returned FILENAME is converted to MCCS")
(LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE))
FILENAME NAMELEN NEWNAME)
@@ -900,72 +902,74 @@
(LET [(FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE))
(FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE))
(ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE]
(AND (> FINFOID -1)
(< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
(CL:UNWIND-PROTECT
(CL:WHEN (> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE))
0)
(SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of
(CL:WHEN (AND (> FINFOID -1)
(< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)))
(CL:UNWIND-PROTECT
(CL:WHEN (> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE))
0)
(SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of
GENFILESTATE
)
0 NAMELEN))
)
0 NAMELEN))
(* ;; "NEWNAME and DIRECTORY are both UTF8")
(* ;;
 "NEWNAME and DIRECTORY are both in system format, and so is FILENAME here")
(SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY)
of GENFILESTATE)
NEWNAME
(fetch (UFSGENFILESTATE DEV) of GENFILESTATE))
)
(replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with FILENAME)
(COND
((= (add FILEID 1)
(fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
(SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY)
of GENFILESTATE)
NEWNAME
(fetch (UFSGENFILESTATE DEV) of GENFILESTATE)))
(replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with FILENAME)
(COND
((= (add FILEID 1)
(fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
(* ; "Generator exhausted. ")
(\UFS.UNREGISTER.GFS GENFILESTATE T))
(T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID)
))
(COND
((AND (EQ (CHARCODE >)
(NTHCHARCODE FILENAME -1))
(OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)
T)
(ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH)
of GENFILESTATE)
(fetch (UFSGENFILESTATE MAX-DEPTH) of
(\UFS.UNREGISTER.GFS GENFILESTATE T))
(T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID))
) (* ; "\GENERATEFILES operates in MCCS")
(COND
((AND (EQ (CHARCODE >)
(NTHCHARCODE FILENAME -1))
(OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)
T)
(ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH)
of GENFILESTATE)
(fetch (UFSGENFILESTATE MAX-DEPTH) of
GENFILESTATE
)))
[SETQ SUBGEN (\GENERATEFILES (CONCAT FILENAME
(FETCH (UFSGENFILESTATE
FILTER)
OF GENFILESTATE))
(CL:WHEN (fetch (UFSGENFILESTATE PROPP)
of GENFILESTATE)
)))
[SETQ SUBGEN (\GENERATEFILES
(SYSTOMSTRING (CONCAT FILENAME
(FETCH (UFSGENFILESTATE
FILTER)
OF GENFILESTATE)))
(CL:WHEN (fetch (UFSGENFILESTATE PROPP)
of GENFILESTATE)
(* ;;
(* ;;
 "Need any legal attributes to cause string allocation.")
'(SIZE CREATIONDATE AUTHOR))
'(SORT RESETLST]
(fetch (FILEGENOBJ GENFILESTATE) of SUBGEN))
'(SIZE CREATIONDATE AUTHOR))
'(SORT RESETLST]
(fetch (FILEGENOBJ GENFILESTATE) of SUBGEN))
(* ;; "It's a directory, so let's recurse into it.")
(* ;; "It's a directory, so let's recurse into it.")
(SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN))
(replace (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE
with SUBGEN)
(replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN
with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH)
of GENFILESTATE)))
(replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN
with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))
(SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN))
(replace (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE
with SUBGEN)
(replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN
with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) of
GENFILESTATE
)))
(replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN
with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))
(* ;; "We're set up to recurse into the SUBGEN above")
(* ;; "We're set up to recurse into the SUBGEN above")
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))
(NAMEONLY (UTF8TOMSTRING NEWNAME))
(T (UTF8TOMSTRING FILENAME))))
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))])
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))
(NAMEONLY (SYSTOMSTRING NEWNAME))
(T (SYSTOMSTRING FILENAME))))
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T))))])
(\UFS.FILEINFOFN
(LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 7-May-90 23:21 by nm") (* ;;; "FILEINFOFN for UFS--return the value of the specified ATTRIBUTE. ALLPROPS is fetched when a file is generated if GENERATEFILES method is invoked with some valid PROPs when the generator is created. ALLPROPS strucure is re-used. We have to be careful to COPY the values that come out.") (AND (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (CL:UNWIND-PROTECT (if (EQ ATTRIBUTE (QUOTE TYPE)) then (\UFSGetFileType (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) else (BLOCK) (SELECTQ ATTRIBUTE (LENGTH (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE))) (PROTECTION (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE PROTECTION) of GENFILESTATE))) (SIZE (FOLDHI (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE) BYTESPERPAGE)) ((CREATIONDATE WRITEDATE) (GDATE (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (READDATE (GDATE (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) ((ICREATIONDATE IWRITEDATE) (+ 0 (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (IREADDATE (+ 0 (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) (AUTHOR (* ; "Copy the string out of the buffer") (CL:SUBSEQ (fetch (UFSGENFILESTATE AUTHOR) of GENFILESTATE) 0 (fetch (UFSGENFILESTATE AULEN) of GENFILESTATE))) NIL)) (AND RESETSTATE (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (\UFS.UNREGISTER.GFS GENFILESTATE T)))))
@@ -1076,7 +1080,8 @@
(DEFINEQ
(CHDIR
[LAMBDA (PATHNAME) (* ; "Edited 16-Oct-2025 18:22 by rmk")
[LAMBDA (PATHNAME) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 18:22 by rmk")
(* ; "Edited 2-Apr-90 01:07 by nm")
(* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.")
@@ -1089,7 +1094,7 @@
(if (OR (EQ HOST 'DSK)
(EQ HOST 'UNIX))
then (if (SETQ PATH (DIRECTORYNAME PATH))
then (if (\UFSCHDIR-C (MTOUTF8STRING PATH))
then (if (\UFSCHDIR-C (MTOSYSSTRING PATH))
then (DIRECTORYNAME PATH)
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))
@@ -1557,23 +1562,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (9311 10864 (\UFSCreateDevice 9321 . 9686) (\UFS.CREATE.DEVICE 9688 . 10544) (
\UFSOpenDevice 10546 . 10723) (\UFSCloseDevice 10725 . 10862)) (15127 63821 (\UFSOpenFile 15137 .
21713) (\UFS.OPENP 21715 . 22212) (\UFS.RECOGNIZE.FILE 22214 . 23644) (\UFS.DIRECTORY.NAME 23646 .
24736) (\UFSCloseFile 24738 . 26797) (\UFSGetFileName 26799 . 26998) (\UFSDeleteFile 27000 . 28194) (
\UFSRenameFile 28196 . 30513) (\UFSReadPages 30515 . 31650) (\UFSWritePages 31652 . 32872) (
\UFSTruncateFile 32874 . 35280) (\UFSDirectoryNameP 35282 . 37145) (\UFSEventFn 37147 . 37809) (
\UFSGetFileInfo 37811 . 42274) (\UFS.CREATE.PROPS 42276 . 42629) (\UFSSetFileInfo 42631 . 44977) (
\UFSGenerateFiles 44979 . 52591) (\UFS.NEXTFILEFN 52593 . 60409) (\UFS.FILEINFOFN 60411 . 61860) (
\UFS.VALID.PROPP 61862 . 62154) (\UFS.REGISTER.GFS 62156 . 62411) (\UFS.UNREGISTER.GFS 62413 . 62996)
(\UFS.ABORT.DIRECTORY 62998 . 63346) (\UFS.ABORT.CL-DIRECTORY 63348 . 63635) (\UFS.CLEANUP.GFS.TABLE
63637 . 63819)) (63856 70540 (\UFSMakeUnixFormatName 63866 . 64887) (\UFSParseNameString 64889 . 65263
) (\UFSParse-Directory 65265 . 65806) (\UFS.PARSE.BODY 65808 . 66353) (\UFS.ADJUST.HOST 66355 . 66514)
(\UFS.FULLNAME 66516 . 67724) (\UFS.ADD.HOST.FIELD 67726 . 68086) (\UFS.REMOVE.HOST.FIELD 68088 .
69758) (\UFS.HANDLE.RELATIVEDIRECTORY 69760 . 70538)) (71356 72501 (CHDIR 71366 . 72499)) (72573 73559
(\DEVICEFILE.EOSERROR 72583 . 73557)) (73632 74869 (\UNVISIBLE.PAGED.REVALIDATEFILELST 73642 . 74487)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 74489 . 74867)) (74902 76528 (\UFSError 74912 . 76526)) (76572 78987 (
\UFSGetFileType 76582 . 77183) (\UFSSetFileType 77185 . 77782) (\UFSeol 77784 . 78985)) (87630 88754 (
\UFSGetPrintFileType 87640 . 88052) (\UFSGetFileTypeConfirm 88054 . 88502) (\UFSPrintTypeMenu 88504 .
88752)) (88784 91622 (\UFStoOtherCopyMess 88794 . 90472) (\UFStoOtherRenameMess 90474 . 91620)))))
(FILEMAP (NIL (8911 10464 (\UFSCreateDevice 8921 . 9286) (\UFS.CREATE.DEVICE 9288 . 10144) (
\UFSOpenDevice 10146 . 10323) (\UFSCloseDevice 10325 . 10462)) (14727 64649 (\UFSOpenFile 14737 .
21421) (\UFS.OPENP 21423 . 21920) (\UFS.RECOGNIZE.FILE 21922 . 23459) (\UFS.DIRECTORY.NAME 23461 .
24590) (\UFSCloseFile 24592 . 26759) (\UFSGetFileName 26761 . 26960) (\UFSDeleteFile 26962 . 28264) (
\UFSRenameFile 28266 . 30687) (\UFSReadPages 30689 . 31824) (\UFSWritePages 31826 . 33046) (
\UFSTruncateFile 33048 . 35562) (\UFSDirectoryNameP 35564 . 37617) (\UFSEventFn 37619 . 38281) (
\UFSGetFileInfo 38283 . 42853) (\UFS.CREATE.PROPS 42855 . 43208) (\UFSSetFileInfo 43210 . 45664) (
\UFSGenerateFiles 45666 . 53078) (\UFS.NEXTFILEFN 53080 . 61237) (\UFS.FILEINFOFN 61239 . 62688) (
\UFS.VALID.PROPP 62690 . 62982) (\UFS.REGISTER.GFS 62984 . 63239) (\UFS.UNREGISTER.GFS 63241 . 63824)
(\UFS.ABORT.DIRECTORY 63826 . 64174) (\UFS.ABORT.CL-DIRECTORY 64176 . 64463) (\UFS.CLEANUP.GFS.TABLE
64465 . 64647)) (64684 71368 (\UFSMakeUnixFormatName 64694 . 65715) (\UFSParseNameString 65717 . 66091
) (\UFSParse-Directory 66093 . 66634) (\UFS.PARSE.BODY 66636 . 67181) (\UFS.ADJUST.HOST 67183 . 67342)
(\UFS.FULLNAME 67344 . 68552) (\UFS.ADD.HOST.FIELD 68554 . 68914) (\UFS.REMOVE.HOST.FIELD 68916 .
70586) (\UFS.HANDLE.RELATIVEDIRECTORY 70588 . 71366)) (72184 73437 (CHDIR 72194 . 73435)) (73509 74495
(\DEVICEFILE.EOSERROR 73519 . 74493)) (74568 75805 (\UNVISIBLE.PAGED.REVALIDATEFILELST 74578 . 75423)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 75425 . 75803)) (75838 77464 (\UFSError 75848 . 77462)) (77508 79923 (
\UFSGetFileType 77518 . 78119) (\UFSSetFileType 78121 . 78718) (\UFSeol 78720 . 79921)) (88566 89690 (
\UFSGetPrintFileType 88576 . 88988) (\UFSGetFileTypeConfirm 88990 . 89438) (\UFSPrintTypeMenu 89440 .
89688)) (89720 92558 (\UFStoOtherCopyMess 89730 . 91408) (\UFStoOtherRenameMess 91410 . 92556)))))
STOP

BIN
sources/UFS.LCOM
View File

Binary file not shown.