From cc0a819cd5b8ccf3ae68ded44f8865ed0a71c338 Mon Sep 17 00:00:00 2001 From: rmkaplan <69548581+rmkaplan@users.noreply.github.com> Date: Mon, 16 Feb 2026 12:06:09 -0800 Subject: [PATCH] MCCS coding for UNIX-GETENV, fix MTOUTF8STRING (#2474) * 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 --- greetfiles/APPS-INIT | 279 +++--- greetfiles/APPS-INIT.LCOM | Bin 10301 -> 10425 bytes internal/loadups/LOADUP-APPS | 16 +- internal/loadups/LOADUP-APPS.LCOM | Bin 1936 -> 1932 bytes internal/loadups/LOADUP-FULL | 15 +- internal/loadups/LOADUP-FULL.LCOM | Bin 3032 -> 3022 bytes library/UNICODE | 63 +- library/UNICODE.LCOM | Bin 24950 -> 24940 bytes library/UNIXCOMM | 26 +- library/UNIXCOMM.DFASL | Bin 0 -> 6660 bytes library/UNIXPRINT | 19 +- library/UNIXPRINT.DFASL | Bin 5520 -> 5518 bytes lispusers/CHATSERVER | 151 +-- lispusers/CHATSERVER.LCOM | Bin 18016 -> 16690 bytes lispusers/ISO8859IO | 293 +++--- lispusers/ISO8859IO.LCOM | Bin 7442 -> 8105 bytes sources/ADIR | 46 +- sources/ADIR.LCOM | Bin 19937 -> 20015 bytes sources/ATERM | 80 +- sources/ATERM.LCOM | Bin 16299 -> 16158 bytes sources/EXTERNALFORMAT | 298 ++++-- sources/EXTERNALFORMAT.LCOM | Bin 11068 -> 14059 bytes sources/FILEIO | 192 ++-- sources/FILEIO.LCOM | Bin 45873 -> 45832 bytes sources/IOCHAR | 1485 +++++++++++++++++++---------- sources/IOCHAR.LCOM | Bin 24112 -> 23384 bytes sources/LLSUBRS | 140 ++- sources/LLSUBRS.LCOM | Bin 13967 -> 13798 bytes sources/MCCS | 265 ++++- sources/MCCS.LCOM | Bin 23593 -> 26997 bytes sources/MEDLEYDIR | 15 +- sources/MEDLEYDIR.LCOM | Bin 7295 -> 7292 bytes sources/PACKAGE-STARTUP | 36 +- sources/PACKAGE-STARTUP.LCOM | Bin 27604 -> 27595 bytes sources/UFS | 317 +++--- sources/UFS.LCOM | Bin 38092 -> 37631 bytes 36 files changed, 2246 insertions(+), 1490 deletions(-) create mode 100644 library/UNIXCOMM.DFASL diff --git a/greetfiles/APPS-INIT b/greetfiles/APPS-INIT index 21f74cec..defae498 100644 --- a/greetfiles/APPS-INIT +++ b/greetfiles/APPS-INIT @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "26-Nov-2025 12:30:08" {DSK}larry>il>MEDLEY>GREETFILES>APPS-INIT.;2 23361 +(FILECREATED " 1-Feb-2026 13:41:02" {WMEDLEY}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}larry>il>MEDLEY>GREETFILES>APPS-INIT.;1) + :PREVIOUS-DATE " 1-Feb-2026 07:58:14" {WMEDLEY}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 diff --git a/greetfiles/APPS-INIT.LCOM b/greetfiles/APPS-INIT.LCOM index bcf9748c7f6d9311e0d80de1e0fb2d5821baf87d..bfde24fd756f8dbf24f1f190238e1b4e5666c9a6 100644 GIT binary patch delta 663 zcmah`&x+GP7^f?RHLFM!4}!`^#C3Z}=%j77JIX>#raG8SVrJ@Yk6SZag1c==TUZe7 zD=0a6@d*YmJ$cwS5PSxo!GjkMPFk$GAbT3VKlA&3f6k)M&)@CO02yu3Gpw3r1FGW& z!Zk~WE&b*2WRxC@1cn39;r0F=@qE&K^QfN*F*#C`@vaj^%%B0~=0k+4py}tZ>P_6V zb?9Yc1tv~M+4w#NXEYj{bdXN+51ZAi+M@J^MFZY{yHQ!xZYB;V!awYZW5~a6S~Kmy z^^FcAF~;P8xRM5(#6D%w63)qn(?LQ`(@A>(sbXF5gTFbMrl~`sKoceDU)^;ZBTKJp zTW#tSHzp1z-npgO%AJed0L$7@hGODTZanTncJd0a`_u`Z5N7ZY)SZCA|MXM=M=^Op z!wxe%#bimO@jIs4Hg2{sYFr%4jyAuw_M_~{!ZnY^D&ZO|ll;>{EeJwR3gN8Su~c1{ z%edqFi%)jZnDh0I>(^u)hIJr!MRYdf7d_!+Y=ZzTfZ6!?(xE#g8F26|Z}wU=8O%$HdTx zwvHf+4!Z4LvlZ5%+W`dWQ-|-IZ&c$jimg^HicYL%%i5)mOZTiTpVFYjT*@uGQsD~o zSfGBzIY4^h6WvPnhtU zq^c@{x}2)NcR@E%E}fmoDf-k7r~~L7j|BuTmWKc439w<9IuPoxK-t_&18TL~2uN|; z_O>Wjf-+=F9*4J9azH9R{m#l&t~gSbRFzjsA>E%uzY4lR@+QH?e?_g2FQ=Z9pG1{Y z-(kLlY4H1P#ONlqFejMD1KV|9dM0>9F@8#2r)Gs;F7I-{W&!-FCq`$PF9|Wa%ItiW z8!TY9D}!JA%letQONjC9Tyo~47|5?68iQs%6yt~a$D~|5UVM`6?WM*CS?*V+6Tbk* CKe5dK diff --git a/internal/loadups/LOADUP-APPS b/internal/loadups/LOADUP-APPS index ec4cde71..3e8cd112 100644 --- a/internal/loadups/LOADUP-APPS +++ b/internal/loadups/LOADUP-APPS @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 9-Mar-2025 20:03:27" {DSK}frank>il>medley>internal>loadups>LOADUP-APPS.;10 3274 +(FILECREATED " 1-Feb-2026 13:45:36" {WMEDLEY}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}frank>il>medley>internal>loadups>LOADUP-APPS.;8 -) + :PREVIOUS-DATE " 9-Mar-2025 20:03:27" {WMEDLEY}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 diff --git a/internal/loadups/LOADUP-APPS.LCOM b/internal/loadups/LOADUP-APPS.LCOM index 54800c0d69073e49f4adfb48a310ad187524e66e..a35022b5f611eb198670bcb7b4dc15d628ff9b53 100644 GIT binary patch delta 299 zcmbQh-@`v4Lf=r=Ej3Bk$iT==K}n%H+}G8` z$2GFnX7X!BIelYI1ui88RGr4AR;ECmNkyq}t*I3SMa8OC3X|j6H8T`4^MINh0|J5- zkago*`={PiOIib2h(aS=K}mtD+9lY# z)+QrAH`Ok!C^0YFE;Gk2H#H?EwbE{4yIj4YfhJHDl2L}HR;C74re;bCB_NY>)Ke5P z^Axz0+(LbP6p$6_>FFscq$HLAZNg@NrIIF>hMT94t8I(#WO_LDN;cR><=Y{$uk(O)C?`HOpL6IfzBo1Q$~x;Y)q|89P!Tn VzP_Fz@slUB_`x}wU$QJ_0svt9V0Zuk diff --git a/internal/loadups/LOADUP-FULL b/internal/loadups/LOADUP-FULL index 037dd5cd..a70c431e 100644 --- a/internal/loadups/LOADUP-FULL +++ b/internal/loadups/LOADUP-FULL @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "28-Dec-2025 12:06:12" {WMEDLEY}loadups>LOADUP-FULL.;35 5759 +(FILECREATED " 5-Feb-2026 10:26:39" {WMEDLEY}loadups>LOADUP-FULL.;36 5858 :EDIT-BY rmk :CHANGES-TO (FNS LOADUP-FULL) - :PREVIOUS-DATE "20-Sep-2025 14:18:19" {WMEDLEY}loadups>LOADUP-FULL.;34) + :PREVIOUS-DATE "28-Dec-2025 12:06:12" {WMEDLEY}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 diff --git a/internal/loadups/LOADUP-FULL.LCOM b/internal/loadups/LOADUP-FULL.LCOM index 4b6d5511af33dba157e36a8805349b4632ea5585..215036e7a44ff3b1a4e86d8928732744079f3f0d 100644 GIT binary patch delta 195 zcmca1eolNsxQK$Ou3Ku7u91O}nS!B#m64g1vE{^UYe_Rr1ui88LnKL4D`O)oQ?rTt zwL_4__4M?V6jBmPQd6*KFt#!nenWghxQLO3u1jjNu91O}se+-Am4TU+q0z)_Ye`d01ui8cGbBlKD`QJ51B;3K zwL_4__4M?V6jBmPQd6*MFf>!rUNICODE.;211 82245 +(FILECREATED " 5-Feb-2026 11:07:12" {WMEDLEY}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}UNICODE.;210) + :PREVIOUS-DATE "31-Jan-2026 19:24:45" {WMEDLEY}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 diff --git a/library/UNICODE.LCOM b/library/UNICODE.LCOM index b14e049ab54d003477503117312e48011b49a083..dead9c1df4d2c0798f37baf3ec5ab7d9a4fd1541 100644 GIT binary patch delta 1467 zcmZuxO>7%g5Vn)Fr~v{*jR;`si78N5T4&$9{pVuGUN>8>cg=d;v}!JG9Z@%?RHz4# zBBi1dTuGlm6-Pjv(?%S)AdwU5gNewzTV=`8?lzZ@yXodzk(E zF#F}kNl>Nw)>R2*)Bt6RYZfYd+pC-xVZJa4GHxMSTq(fETh~7N@K&$C)rGB3ZuNWD zdbj(ZzHNbExs#jFy9tGQ$8}+{xKt_?pnK&ul}uw*uuz;oQ+Hgu8rYT4u0gsrvt-?3 zC}1Z490vn6Sr;7mGy%}T?T{$IrS)I8I1O8$)y7-v&}5KNI>S=t4~oQBd! z(d5tx>qe>VcFvXjPFP*91a%M4P{1NUGNcHhQy}cj&8B6Bms<8)JAkS={4JnDhjqwX ziW0~FijhFP_l3d!!ekpKsCr@xy& zbN(e-{PKxt>A!uD5#>iSFW(sakR^hLimxc4CQr}(YZeDB@nS8n6+ubI!>#^F!> zJI=HFPB$(ceDD1DeDCwd_LIx|e_UVO@0Po~Jb1WS{$=LTEZi78+z{UC>Ec;`@oRs< zC5F57b@+4tj`!@ocSPYu6z=wu&HdjG?yZK|U7bOD-S47VV4((3uRMhDw4O#!3BiX{{YKbex?8b delta 1395 zcmZux&u`R56kdnWszCw-NlH|dyey5BNZ9erc>Jp%;@$NUD_(oCy`&MjAQGt|;fGQV z+%{^Z9*~egBanKk1pEPkhyxeY=2Z27I7UeHz_H>07tTD}o85KWm8_ljJ-_+B_q`dv z-<3Y?O7|9rDU-u1w`8hP4ytK0VpDQ|eYQo}dg;DVAkMmFz4J$O zv&RF38yybKKp`gwG@9x;XaHd;Fm_PKRfe@W5Nhn#RyrDq-l@xWhr{b%VXe_{8<#+LW-iTC`_ z+Aj<1dzZG~{cvpi(%cH0`|vED`(xm*190`jvp`JFehZV~v4`Pd9}9oRzulJ`TfxUC zL0ajr?=5fty>opwk=mR=JRi3FT95$O42YV3I?n9=bNtK{VpT1~8n)h_*ECX$iB*W1 zr4?gtwu=DMi!n~CpMV-VG?K8DsiQjDm&|w7Qq2UsYhg7`A}_!zpfL#0Y`hT}fM1ow jjlr^DYRZWsXGu<$n&J&vIgEvP*bTxdFkRpADa?KbpGIxt diff --git a/library/UNIXCOMM b/library/UNIXCOMM index 02c27436..978d96cf 100644 --- a/library/UNIXCOMM +++ b/library/UNIXCOMM @@ -1,14 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 2-Sep-2025 12:06:52"  -{DSK}kaplan>Local>medley3.5>working-medley>library>UNIXCOMM.;14 14825 +(FILECREATED " 5-Feb-2026 18:38:23" {WMEDLEY}UNIXCOMM.;15 14717 :EDIT-BY rmk :CHANGES-TO (FNS FORK-UNIX) - :PREVIOUS-DATE "29-Apr-2025 22:45:47" -{DSK}kaplan>Local>medley3.5>working-medley>library>UNIXCOMM.;13) + :PREVIOUS-DATE " 2-Sep-2025 12:06:52" {WMEDLEY}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 diff --git a/library/UNIXCOMM.DFASL b/library/UNIXCOMM.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..119a6d03d9dbb955b2f3459d0d91890008b559ba GIT binary patch literal 6660 zcmeHMZ){W76@Pwq9LEX4CZ_x;gjW($nqoJkO;c{QN5cvM?x%ZxT?z!ilKbHl;GZfLJNMUk1m(R>dg}K@3xmjtvFe4QUb2CRX z(m2qi(+87ER8xlMpU>xx%#6*vbYMVNhayHY8QQV8(*``o^#pWD~{v^OT38t1q=&C1Tr6pxL)v`6ZZVE)V;Fqd%Ap4zIFZrM`T{2{cD1{D}MamrHw!vv9_fMfjkE6Q${y!qH5z zm?=sf(sVI1cdQ`IW@aXHQ)BreEM}Y7=5i@Ho6Qxa;_Te`xKzv*=JLlR;F8b3Bpt~} zxyk8#W->E{hLfA3)kUc=E}b^xil)s=V^hbZ(#&i=JZ_G$1g2WGc4b(&Fv4d?ep=uh=qt3y!YAMib;fBQ51x*Xi zEeYg}6*4F^qL`*_09WI^2+C<=K#wXzsucrMs$<)^CR)p-R%1FdGd7zmOu-&uv)K$N zB$Llq_68bfkHI%Ksk&;ZvZfwVDxZ%kgK7k&3XqI_iWStAAuAXjh{cpN(0xP?gUR7> zrmPx`OCD5=SPJH?r+F0`m@kn0c2Yz$Or?B91iH6RGs3bqD5p`0&7GvcAeW>Q_60;w zREcPETGaxUB1n2AgC1xOp~3;z}f; zCR0Y*0y7oCZPdLmV1QxKmfd(rssRk@HO(9dr_FPGoeS?Neh?>E!zqP5(g=zxe^V@% z0uS@6S4*v*?V*LY*-r4GYTh$H=eYh%zOncE=HBBjDP@+$H*+18t% zbNYb7eQe$Z9DIU+ZlWFy9o#DTO%N8mTatv`34BEKJoNXCQbUK4LWe4AY?Qr--mmHk z&xxOBZJS~BMs$op%izbc%F6j940#P*iNbYC%fs8*crzOp_m)dS8~lS^wUw_q{1d$- zEeSY3CxUb+kQ0uYwE=ciWD(gIn_x%JInXOKB`w1oHersc_c@$w9J#dvw{^X5=AFG0 zxan+#6Sx^&XYKc~DgY}W!LnWDYtG$%pKyZ9!F2}=hOSOb#D9D5Z1znLPF!02I1Vui zWoy^TgwRz87S3RL@K;$EL#SH-Z z?|A7{?_>`zB+ip0w6mrD;dfMf*Y9v?G&3FuEYXgrr`6yc_tt=WNvlOs9zY)?;E9Va zHbH0P!V3+?^CBF|DC?+OdnjPZa42=CbMzHn?pN^QBB_JTLnHhZM@CG=LSJK=NctU+ z){lVKR?=`GAPOaA%gJ`O;HqvIYe9b$f+bP75Sl!UHwwpsFxLDa8Qt8*$`Ut9@Tog8}ICg%6 z$qgh%@_=Sxf0?hIfjN|bX^=5-BOga0MmU?0Zdf7AoDR|Si#m)oj3^Lo(rF_dhF;@{ zZm3Dfn2eMeg8tUkm6dOWlJXFbcjji+gQovD+&&b#mAkQu<@+9H`Bi)TuU>)wz2(>J zn!QZE5fi5*dmL=q?i}$PzYbQ7>J&aruh$YX;)wCgZA7gcWWw{~*c* zT=^%0uOj?4!LK6x1z++qHLp!kbMXjo2B~?ypPEb0Qd8Q*PkA?YaKg`f=^Eb~x*T7W zDtP#^x)`Y7Lks<{R^avUD11=hUc~KpI1}Hi_XvxDgacg$MT@1Dgm`Q5FSU6$$Wz~p ztAXs2>U#+Pp@n#r|AE@NJMNp=8-8D%>I4DKE$(!@H~DG4Imy2rfS`2m+pi}1Cspz0 z;)iiM5`N__fXhMETo9e*%ca1s_V%Qlf@&jeLb@^#hRA4@7oZ}5aAhe;I=?z)P|+>6 z8~ERUfLB)!@Ljk)Zp!3hqX0MZ<-xVCN2M>9oALWU?)Xht7Q;g|gU0PE@I{DQ1!7ffoDW8nTco2|9JJg5vNn~@2P zSGZyl$`^2^c;$mo6oG7x7e+xqVaL$T_=&rMw4?$c>wrj7!+UHvWW!xH?6cvh4aaQw zc^kHD_>c`BSW;Il=pC}5{^1)uSOwBc@hVQ)ux`U~8xGrWuMO|B;Z7TtY`E2ix7qMk z8*Z{;&r-ZnNV1?4G)f86Sxh?60Q@eC1n2^RV>UR-hjo32Mr|3#r zjfB#QE+?UO)+mCt5*wPfp$6SmDEzAi{|0=TZG7Y?hE?GYYsg_RF^Z|bsxAB(%QR7KWbXN{&+;_$j#y~}{tY5eFxBfF`39AoP8|GWfKRxU_wKln zI2?yt5r?ew(An(uj{e-etKo&LZ}GO@=i<{QmW3sb`j;I`Ejb^K^O))*_Lv)ie9a@2 zzNZIL^nfAa1$9EG7agoXiIWrdEg;pa8x+@LS|6_$4#s5*JO~&VZs-CFK>%`AvU3+? zx}1u?KOy{M^krWLP98IE3}{i^ItiUdNEl)vnci8pvoFD#`>J#7M;I=UFcTmkX-n+3%oLu<;!U5<;^-*oqOIavZ2AnT@N(95V zl^A>zaCe@AFV>L)ToRwVWvxWK2WelaH8M8!_^fnf?C1$;ZW^8h;HhK|D_WDDT0r71 zka+j1#O2=GLho(Irywt$5!pqKl3M8IY_fHMm=Be$m4(F3^!=M67X#I@7iz@z%0~jc zjG^5^(DTtps+&hc#RR!_mV583T54zcKAfW1ip4J}V?EpD+zf$kJx>XPkP-$lCBzu# zA5zlBP!O{dLl0t2=w+vD0(OHI_N@v?;k0s2*)_R;?wY#4n-JEY{J=}Yp-@?b)Y;XLpH zVj1uT0&gOM1K!z0c7W}Mb5JTNZCk#HZx#}W|L3(2R&@8}wQrO>DcOo+&|%6$a@!Bk z5YaC0@!aymzfyHau(R*MYAVhYwAz+{5~}e<6D|x1jp6x1gRM zd5^0C>iHyKs%jAMss_<0h$%o}j~EO4Dh&#I#5_ytwBZgLZm-RU!XD>iVb9xUYT=VY z1wcJdBT&y{%jXgWECG*nLuTQ#`7Bfyh8BeN#0CQ^ZFO5xx}lV(vz%b xjfZJk>suc9-wWWn`r405@l;;>O~K*7r_@InK6E!#9y95`GK9BKls~Sl{0HyZZ}|WK literal 0 HcmV?d00001 diff --git a/library/UNIXPRINT b/library/UNIXPRINT index c637e5cb..9be14555 100644 --- a/library/UNIXPRINT +++ b/library/UNIXPRINT @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Jan-2026 11:09:09" {WMEDLEY}UNIXPRINT.;15 11553 +(FILECREATED " 5-Feb-2026 18:37:09" {WMEDLEY}UNIXPRINT.;17 11663 :EDIT-BY rmk - :CHANGES-TO (FNS UnixPrint) + :CHANGES-TO (FNS UnixShellQuote) - :PREVIOUS-DATE "18-Jan-2026 08:44:40" {WMEDLEY}UNIXPRINT.;14) + :PREVIOUS-DATE "25-Jan-2026 11:09:09" {WMEDLEY}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 diff --git a/library/UNIXPRINT.DFASL b/library/UNIXPRINT.DFASL index 6b582ab0d01702b1448f02f9a4f501fdd191ae6b..8338e31b91bb7a5314063e1c0bbeb086fb6723f6 100644 GIT binary patch delta 448 zcmbQB-KRalHNl)KIKQ+gIaMJoGbdFcxhOTUBsE1r!Bp2RHA&aVz{pI&(89{t+{(a` z%gr&^2US@}Mrl!TN@Assf~f*feNky*QKbS%lMYLB+1u=}99L1u-YtArdrtFMq za!m{jOv0PHS(q6o_p|CVW=-DD8p^nKvMAdmWg^K)|(^HM;9Z)Ylis4YM__88wVAJ5ueNBHjfvCiMvW`2@R$1nLF^ z`8&J1y68GP2D{FT0I7+cF`*_+ll{3WnVH;;H=p5J#0X@VY%b!dV`98M`6HhTW94KsekDfb$&vi7 YjF%_R=Re5K;~U~192vYhLqLNS0DvimVgLXD delta 451 zcmeCvo}fL!HO`bPIKQ+gIaMJoGbdFcxhOTUBsE3B$W+%WF;CaXz{pI&(9p`j5{S6m z9D{vOl?9jPr6gAB0F^5Mm6s+KRVskA=s@)tnQmOVj9C!Fu*oqjD!ir)b7soUm?qc6 zz`!K3xtE2RkuhrW1Xg{h$eHd!W(0p3Xt8jv=1@elCt7U<;)u zPvD%%_%o=kXup;Pnmh4-Ij%*qkPy!3qFPjfQvt diff --git a/lispusers/CHATSERVER b/lispusers/CHATSERVER index 3f7130bf..8f598a84 100644 --- a/lispusers/CHATSERVER +++ b/lispusers/CHATSERVER @@ -1,14 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 7-Sep-88 17:08:57" {ERINYES}MEDLEY>CHATSERVER.;11 47957 - changes to%: (FNS CHATSERVEROPENFN) +(FILECREATED " 9-Feb-2026 22:25:32" {WMEDLEY}CHATSERVER.;2 45227 - previous date%: "19-May-88 00:37:49" {ERINYES}MEDLEY>CHATSERVER.;10) + :EDIT-BY rmk + :CHANGES-TO (FNS \CREATELINEBUFFER) + + :PREVIOUS-DATE " 7-Sep-88 17:08:57" {WMEDLEY}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 diff --git a/lispusers/CHATSERVER.LCOM b/lispusers/CHATSERVER.LCOM index c83e894353fa464b8420fb1b95ae53630df868eb..0fdda446acd602d1ea0b751e8cdc04d7637f1196 100644 GIT binary patch delta 1003 zcma)*O=}ZT6owfkwT!lrYLN;l*C~}uOJX`nCduS;lDU&koqTj=l29quexx?oHZ^IX zAX?FdE{YZg7Yd@daiLT+^as?1F1pc;8zuMy>_S12cH_CJv=s#1Je>QUbKg1V%*^Ly z>eUTuCAmb?c3DwzLc^kgCB&eBLoSXvI2XqwjuSYq;N}=)XU5AjbEWCx1S-!$(Un39 zODZ0^8k#Ou=N78PN;Q(`7Y!Y2d8|2u9E)fM`S+~)0)m$pJRSy(Rf@Y_#l@w$O0`=+ zv*r1z((FZ40&_X1s%U>3PN$PW6QlF+a4_B1U!PlWae|v?*#8>hZ%rG2bd5Y-j`JY_ zON!x$524D;B_u#aI*E0MkwJD^PU~oRXIZL}#_^miV~s^ZR>OHElhYj%tkJYmC-{GC zsE?)h9xb|Du0AA4e!5nt77tRiS+L|Oy0&VODL8y@dIY?8s0OT4w%TNK(gNXXO99x_ zx(Zxt4MF|4))(aRleRSQYuiJR?jCzeEPU+?z&h1g+h}(l27L?l9{?rMrNUvQYa5Dc z%iSM{Hg10d>|tMnw8=go*KhZh;qbHf7O}s6W(~-@?t}Es)kCCh_c(CGGYVYy6oJ>` zlfXOP3E)72#4i))fk!2xboz+$Nh18>y8ul2HS-5PZlmE{YFTk`5J`%jRmC9#YbjYx zA}Phf4gblGoqQAx>q;uCVkIReaVD!n)*9fzX)``-rA7U04n9W1h^s7QDBcelif2u$ za0H^uJlmkn?BT6`+Ad0xk;#i1m=aAsr)3>%F^(cXJ1C}}BE*iD#q$ptnag%Myd zNCtZxB*Rc4GT2mz#OuMR*&Mb(bUJ(rSdQ4tVi-g8EKJtb5+N)%_&zf5yCM)(Ai5c~ x1D{7bfg4c)*c3Yl9F36`zl}L9@Ix@PxfSc`XhaN)>0hd$6iomC delta 1230 zcmcJP&u`mg7{`@#8Lhgvlc?5-Ntxa`8rU02?Z%FsH*L}^dE1&giEF!Mg-%_TxLwq) zj*@n2HBFVq0S+7{y$AsUdfc=FlNN24{Xl>OCoUX-8}L5>hfS0Ays4noG-;>#@X_-; z@AKnpKd*e}TIkP@L)Ry_kvL&mwBXRZM~hfc^msYA98V{)VvwXlMn(iI3bo);v$5*e zaj=F3e5L44Umaa(tSx8#&1TSA&#pGw&05g%yT(S_Z?&_9sl4Y>XO23Fj3QwqD9Znx zQ$&O2NdaG|ZA0hPx9Ye7jZ1!g)!)KSuZ~)#YtMorH(R1bi_Y&V-2P9Zf>k}O>9}^Wy0+}M@p^EQU~!`C zVzl=v6`PhP$`Wq2{L77Cqumt;d4iITm#SNQv@DY(s7t?mba(PG_&Tz*Z$w^}Wd)O> zf!IuMw9^xQzbAy)Vq`9aI`<+IA#k1^+yQ>|S_eWiz4Zt<_t3k*fq`#;4+lo!;PJq1 zUU=*Eau|s$BWY}Sa5;iR8>=kn#hv?uAMjqeBO5?I>6atJ{ZJP^F%^c$bj$+hv)B_z z>U?tYR~}mte*}(5-$Uph=?h+d{d5pQci#SxkNRl%E-)*94#&UCr+BDGtpS(SDho~@ zWq+s@@P@S|;HO$0_@rxx$Pn91O@aSiibvnnmwFHunXL@52jm$0R#zeVw|*WtYdEn5 zhn6ZHO`I{yFIbKQ4`PpuH&i4#c77&@_x6{toeID1aC3H#7F@GrThuJ&CuzlYp|C$a z0%N|`77nAlJIybQ=bf>5%f6HWCw(c2^^-$jZKb3xqim5J1}h*#z#Vcl49Po02j@4k z2-GwDt-j1~{ZBLe?dzl5ewfLz17p$H?lpF;O1_8-R^0REY0>oXt~4$l`mJQ6tU5-a z>c&_V*q7y8>GJ37J6$`X%4}sw`V=rgYE8H3@%jcdB>cb^5AcC)^7!yxDd49 b-%?#~1Zx6T(uT^RailnO4g>a5HZAlFuc%YX diff --git a/lispusers/ISO8859IO b/lispusers/ISO8859IO index 0c0204ef..809d08d8 100644 --- a/lispusers/ISO8859IO +++ b/lispusers/ISO8859IO @@ -1,39 +1,37 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS) -(FILECREATED " 8-Aug-2021 13:22:31"  -{DSK}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}ISO8859IO.;19 23459 - previous date%: " 6-Aug-2021 16:12:42" -{DSK}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}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. T)]) (\MAKERECODEMAP - [LAMBDA (CODEMAP INVERTED) (* ; "Edited 9-Mar-99 17:23 by rmk:") + [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.") + (* ;; "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)) - (CL:SETF (CL:SVREF MAPARRAY (LRSH (CAR M) - 8)) - CSMAP)) - (CL:SETF (CL:SVREF CSMAP (LOGAND (CAR M) - 255)) - (CADR M)) FINALLY (RETURN MAPARRAY]) + (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)) + CSMAP)) + (CL:SETF (CL:SVREF CSMAP (LOGAND LEFT 255)) + RIGHT) FINALLY (RETURN MAPARRAY]) (\RECODECCODE [LAMBDA (CODE MAPARRAY) (* ; "Edited 9-Mar-99 17:28 by rmk:") @@ -546,12 +552,11 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation. (OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255))) CODE]) ) -(PUTPROPS ISO8859IO COPYRIGHT ("Xerox Corporation" 1995 1996 1997 1999 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1909 4233 (\8859OUTCHARFN 1919 . 3222) (\8859INCCODEFN 3224 . 3710) (\8859PEEKCCODEFN -3712 . 4231)) (4325 7866 (MAKEISOFORMAT 4335 . 7864)) (7926 9844 (\IBMOUTCHARFN 7936 . 8739) ( -\IBMINCCODEFN 8741 . 9222) (\IBMPEEKCCODEFN 9224 . 9842)) (9928 13459 (MAKEIBMFORMAT 9938 . 13457)) ( -13507 15354 (\MACOUTCHARFN 13517 . 14574) (\MACINCCODEFN 14576 . 14940) (\MACPEEKCCODEFN 14942 . 15352 -)) (15438 19991 (MAKEMACFORMAT 15448 . 19989)) (20058 22117 (\COMMONBACKCCODEFN 20068 . 20438) ( -\MAKERECODEMAP 20440 . 21670) (\RECODECCODE 21672 . 22115))))) + (FILEMAP (NIL (1840 4502 (\8859OUTCHARFN 1850 . 3287) (\8859INCCODEFN 3289 . 3879) (\8859PEEKCCODEFN +3881 . 4500)) (4592 8848 (MAKEISOFORMAT 4602 . 8846)) (8908 10826 (\IBMOUTCHARFN 8918 . 9721) ( +\IBMINCCODEFN 9723 . 10204) (\IBMPEEKCCODEFN 10206 . 10824)) (10910 14441 (MAKEIBMFORMAT 10920 . 14439 +)) (14489 16336 (\MACOUTCHARFN 14499 . 15556) (\MACINCCODEFN 15558 . 15922) (\MACPEEKCCODEFN 15924 . +16334)) (16420 20973 (MAKEMACFORMAT 16430 . 20971)) (21040 23436 (\COMMONBACKCCODEFN 21050 . 21420) ( +\MAKERECODEMAP 21422 . 22989) (\RECODECCODE 22991 . 23434))))) STOP diff --git a/lispusers/ISO8859IO.LCOM b/lispusers/ISO8859IO.LCOM index ac6c89f1cb160d648c3fa2212f85c187ba7b620c..30f45446e65854646aeb6852d3ea1075ad40ae10 100644 GIT binary patch delta 2710 zcmbtW&u<$=6t>+cG%f^}pb|wzOtz>vm2GzB?GM|jARBw#y0N{H?Un|DtdvAFBu%5H zoGP^90vrpzaYjfzfRLino|?aaKY>$)daXEcg*QKUk*JD5vb=AA2dg9uCX>kpyDvTccIlH}CYPr0HB(rc5XPGmL>ldhKVpsuZ?yUkG0-1zNU>`2C`jR^$Ol9L6QZknc^A#zN>XgA&DRW3N09&pD4oT-=rxs%QVk`sLAhY4q zBrUL2f(W^`U<$TLP!$<$nILzsngh0K1wx)$M-yJ2%m=996_-546}K*LD|hC}PV<6j zNEHxh!pm1wspQ2MQmg@QEYO4*#Z)9Fso|(D53{XU2cYO#Ov9QdmxuZ6+|=3w$LR46d_hI)L6^Sahb#iDSt;wHC(`Or?raG+3+!=OpZyRva?t6R~4j zI8M@6eI5XMFz&SG&_jZ$da9kxb;7jh+&INg%MOcU7Hi#MbrMW912wNPzWGEm+=L+C zLlQHs^;A`mrdk=JR@F4j(YT{31oAYP79KiDFqNA+M0jqXg@@@R^K=X&JUnDLxfndd z4o?}uSDin?nHHWpfdr<7mpX$$>jE`nf@xk*i`BCae{kXyQ2c@ zZr$D}QDiuNa-9CRui07tHM<)2qpSEiTkbyVQ+D{(RAuu2N9YEPXGS<%`0|DK9TM13 zb;&B;hJ@*HlL^z|CKV>*rY%fBvnDKxR+WekC|W-0w=Y~AqUDiJ*cy(1f9>tu!qEioMqQc4f>E7<2zl}~GMbo3XXf`_iU}h!v z!B1c8WQr7kG&*&D!6^s*ez1n=FoO4?KEL}^n&JvXYL0<0HP5{0aldAuRpR30v`4%x dQ05>0I{RZ*UNG*?%?ji2hq;;DM6cb+{{^qMDpddg delta 1947 zcmb`I&u<$=6vtx+ig13Ybs(x*wM;BkvLnUp%KXtIU?5lqy05zF-j;eF;?O%NAkJd(Svb+ z(Ay)UA)GP~Z?`u-e`oWcH#sQZ?~VuEVYxoq?GDNhdV7Q3r@ZKt_xp!ydQ=|t55`A{ zZ>>Fzgm7dnD&C}`@G{SmB?m}}{2xtve-U@@b%*=CgBvBXtwN*CPH@L>RU2fxwjQ1t zg??~4>SLMJ&3c`jEvQ&5=B8w?dx$zRFO{m%+{vAzAM}5#pD@O#Af`ZaI6{s2YNJgu z=dZLt#*^O1{n61uQW!Gih?ACwTw9`HF;>EO;qQ}`c)A!$vSF&$q zY?o}Wqw&O!znZ(Y%w4j&RcS?Aov7AM;zGZ<8vm63?A62^hqDjkALf_hUuUz%@_hD> z_?Ly{tEcYR1!9wY-ldFsgt}JzVxh3;Sp}j@(jwGjvAbBBT9Q!Vz|6P<nOXyx)!v-x+qcqvMVSoP=?5{EXSEo+y&OcJvYwI(SNy_*|Rru zJyf^y#1BbxlIP%zp7&g%RJfxJ{ab(nLB+T8ZS4GEo#tB#J?KiL#(v610&k z9$tAn{b(Wn`pV5|?!w0GlUM2&Qy-+lbn5v@P!ChTefQy$8^hGh{tSNi=G6c9^-C+S zV`eA&tg&-3T8y$!ml~H==EKzB#qT?ppCNWhVyoiByjZ?iBuT3h<3B6f%ukJ@Y3aRnJiX diff --git a/sources/ADIR b/sources/ADIR index 5dc4d1ab..43bdab1a 100644 --- a/sources/ADIR +++ b/sources/ADIR @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "15-Oct-2025 15:20:48" {WMEDLEY}ADIR.;62 70135 +(FILECREATED " 5-Feb-2026 10:27:45" {WMEDLEY}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}ADIR.;61) + :PREVIOUS-DATE " 1-Feb-2026 13:17:10" {WMEDLEY}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 diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM index 8deb5dba33efeb40da002c6809e54047e653e914..3839849d7f2afb0388e5bce71cf794a51fc7bd19 100644 GIT binary patch delta 568 zcmZvZPixdb7{<-P%PNTAZ4n*=3%kg~Op-~~0Za2|vKu-(iJ4io2M^XRQrfj;^&s@n zPati{Q4iic_RzcE#iQTCSwSqVb9kADdEaM#Jnzph&c#>f?BxS6QZ9B#;0H0N&x3?V z?0o<6Niu>9dgYDrFyJh9d)Qem-X1QG_6`=iSbREKeHd_5%80gUh4ET3^YR(?-oq{D zQsSzK=Xox6-+Z)#H_SusNA9RMEGsGUwl7j63fuKRyyO1s1c@I+3AiXKL$YnGmiyrO zG*uI!iK#Ixl}7J6)(G4}zNqTCCWZas8b-)z!l{3L+;`&3@6PFl^Q%iXpWOfP?v_1& z%HjHUw_9#roCFlPthFc+&2FN-|Y14rVk|W4Zt4B+F7D{GD zmQM6f0w$7iV98tCi!ov}CHG0O_oY505dzKY~?qq4#b zAbKUA*4Y+{Qcv|*$bXn<~>-UfnUnTUas7~xb)s{c|WY#esb&E;SD#w z{j`04N`#{6w5$-b1o@8M)%m;vZ4y-9xG1XVN(o8{t(jiqBt?6LwCg7QV?o4Gw?-cH*yOx%eHqV3cyYp`io^R>Ikaplan>Local>medley3.5>working-medley>sources>ATERM.;5 57463 +(FILECREATED " 9-Feb-2026 15:49:51" {WMEDLEY}ATERM.;7 56918 - :CHANGES-TO (FNS \CHDEL1) + :EDIT-BY rmk - :PREVIOUS-DATE "19-Jul-2022 22:49:20" -{DSK}kaplan>Local>medley3.5>working-medley>sources>ATERM.;4) + :CHANGES-TO (FNS \CREATELINEBUFFER) + :PREVIOUS-DATE "20-Jul-2022 17:05:17" {WMEDLEY}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 diff --git a/sources/ATERM.LCOM b/sources/ATERM.LCOM index c4e8dec5e5f7974894750a04d7bbca6ec44e9e56..a1b7ecbf6615af500aed4bb9c9b301977cf7ac47 100644 GIT binary patch delta 312 zcmZ9H%Syvg6h%=AO2CgWiyLn}Y~xb8Zv3O(eOo7M!TfK#B^jj>Ps8G&uJM z1SkDL15QH6d$ZQwKg;jM=V%vv#>+cq8I}j8i>`sTQB6%HZJ%R9*-HO`5LjDok!)%1KRXT5L2dv^`Z*+B_EYPYc&dE;_Z*RN-wj zq)^cK{e1rXI=e6D7uCmB)B)G?%`PB?v1Gk5%pRwJ{U}HVlrxz^n8%Syvg5QcHtfIAm1TnuL+4VsW^b5Q~{N!w^lLN3*Uo6sJlHYO!$Q4#Gc*cb2x z1UG#PAI4|!M1?B2aq}%^n4fQEo*!QpPiI@a!dQ672%I1RujsO-bINkEw=L6ve)S|> z)O0~zzV0j>&xw!Bz_pwxaN7eI=YTqi>ym(V7|XH3k@cDx8K%${YtJPmpf+I`1QBE}*^#8+FZ z2!bw=#W@7jx68p#ng6*+tGA5?*B~NcWXBM%-ueB_t7eeILFfk&d@6(K2ZPY*_F`zF zKF;SDcHtbC#VwdcIW5X`HZF1myrz;%X{uO*d{0y58m$^i4V6ISfLxTPY07h4>I3kb Bj70zd diff --git a/sources/EXTERNALFORMAT b/sources/EXTERNALFORMAT index d5c22103..452ec1e9 100644 --- a/sources/EXTERNALFORMAT +++ b/sources/EXTERNALFORMAT @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-Jan-2026 21:09:02" {WMEDLEY}EXTERNALFORMAT.;92 39722 +(FILECREATED " 9-Feb-2026 15:54:22" {WMEDLEY}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}EXTERNALFORMAT.;91) + :PREVIOUS-DATE " 6-Feb-2026 23:21:32" {WMEDLEY}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 diff --git a/sources/EXTERNALFORMAT.LCOM b/sources/EXTERNALFORMAT.LCOM index 1a705304e4c25e7e17ab049d5959c05266186be8..8a026d9762a51d0379f2773ff7032ccab1d1817f 100644 GIT binary patch delta 4024 zcmb_fU2Gd!6`paLD4ET6?IcYT*fyumPwgOE^W&e`D=i+|<78rc#u-mag0kD@57Ihm zyJ>_#z5#1&QuHpgw?z5CRpJ2gC!rT8Rg=qMUnY zT-$NO7KsPXT+cc8o^#LnzH`rg^W5LJzV(>_NQ83hDOQk0WQ%pVj2IlZ7|EKRkw>>(xB9Y2seynhWnf=E0f%aGKvx*bX{!uD1Lgk)w$ zHKw(4$TlHxPPNLQE!di6sD+$q6;(T97Rx~h)$ZoRGj-KD}sbW!o%fGUc2>HjYjB=+HKsq~v?Y zzR=mz!EwE0xbttFYtw@R1BCB7<%!7zx)OZ6_SvrK&T7`faoiRBaXueE({bw)pQq!# z9{M~*W1o z4A)}4U+S*uLsxjY-G3H<5=b)WfG-hLF%na77=sKx6*4zIT*ZM5216QEf}FdD5(dsT z+4r1*3rHA7XLmHDZjyn2@kx&JsCykR-{7B3{elLzHtM{;lX5Wi>?=;FZ*@EG749Wh z;`N>JRA+AXtCg9jjxVl#{|5Jw6O;>dom)8uJoaD#^YI<|OKh~CXJ1oKP`&+%>Pz<& z*VxpX^ZUiMcRk)q@Bf7TzrMlHy}$d*cewM%>#`p*+1KuNENzi{CxZMk`PYe&YQ8`3 zcq}+C!^aExiaBt+?`L(pvuxt+*^1B8YYv%%AKp~@^}J)kTV%rLZaheseQ%h@3-|7F zU&q(mck+hgb)j;wwEJz{9Lj^^xj9t%&H16-+gw12OI5H+1*|t##>{GAGToR=6+u#Bl<$aP3M9sTO)Zuz6aONjnhi^$2xdt$P#sku z9&h*@!OiG}f;O!d!m2e5xM*vwP-KyO<>aRZ;|k=m8WxinGfUTzq6rjDh9xPE)!8k- zZj}MtQ`)p=AR)q+4Ku4_@GR}CFs0BbOIWMw6CA+Ovg5jk72h3Uyjrywq1%|~)RPj{ zpfu%7ojeU*IE-3Cei?5hk~D;}3P1GI?0u2!nZ8}9{5f?MG> zvUp})vZ%hf?))Q3@rSz|cU*}}3C0p*>%l>O^B4o|!CNf~FTd;g=4ST&^WJ@<_(82Y zVtNtjhJ$qD?Kfu&4$_Uv!SlQK`|BReHq+JN(5y=uE+9vvU^x&28P60aD-2<>f{<;7 zHYRN;jjTZIDu~_cBTycjI)w6Q1LY2)VMHPvQjl>jyKo zW;^TKmzOu;b62*vmUm!v`SRHv*j~T7y?$-|@(w-3S1#h`jpgm-RaCu(?U>slk;KRu zUL+SrhUOS9HZE;A?=|*%vX=rH{fOY1tmd^t{Q;6wNi-6o$c-^37CS|Mr-HSPjl42Q zSb0jCmQU*j`j6rD9WOe^rM}lSb6N(=eV1;s9?v~qL3oH&pc{3}?G34~Z9SkHX0X`nQOVZ7SGkMSJ|$n1edK1- z-~Y)jrod^=B)|iXd<28p0Sd~L`WJ@66r%I5bv$C-ckt-GkG4eAkzof})&D!P+F)|1 zzo*%bP~b7e=WOl2;sPOx!2Fmig99LU#pVSOp(lD9Fve@cAiU=p*A_~qWkX=PV5Zdq zyRJ;Oo^0hwATNv#bq4X$A`o*lE6^K^bAcf*J~3Er?Vy{RTAcBy^{GmG4^P+E4c%rw z1cakHedl@*q}o|6Q&27P*7zy%(^23B^1IQ|K9r!yad8r!c?Ja1J2v0TV3%QSl0de` z^2w#ljF!o3W+4;KScM$Up*J$2y(4Zr)X4{Dp053KtdH*u`*9jcO^o){>r^9wq&)GB zeh9SXi~MThM?^f^U3=l|D?Isqz;_ZkQZjV|?}*Ixxp~vp@MiP_PmnLRxr2RmT^T)g sE|l2r(F4yA+C(jvK_KF!HD;C6xlbQ;Epabjq&j)~Y`g1+(CcvOKjRwXA^-pY delta 1703 zcmZuxU2NM_6n4@dwcgq#?I@`<=&83>$uy_Fwv#2E#OgRVu@}b_ytKO79^ehcD{2>Q;!jk97seAvNFeco5HG+B(w=yNYbX61M9#hEo^$T` z`_8$4E`2ex`O---&0m^Z=0!nFf`}9$tq9UqLq=&a1}t}2ijX1+iY#z2->hF^qHbiq)8ESae#g3(#Iom0!ZVZ%?gJ%r8Qs%SN z19c$t>aC`iYXXFnB1?*ZIAFK#a=|oeT@1bxB)@iZq4xDm)x~AkF|0g!rssA~R~N$^ zBbzR>V*Jm{n(rD*+4;tVOHp$35NrE*TcSR9vupN>hp|#@5Fk` zy|zFP&TjwAM5P2!FD1JSk^mLUnC0`>#nuchj*LL5xH&!rC<%(IJ9Z_nQ$C0?aB*M4 zfeca3)GliyZncCt@MzUEJ%Sd8i?yB%yxv!RIwMfBDK=UHB!U5S6F?PEDnZF4Xmpjp z^3$iJ2)T9@JUuulO3tDTfy@b`8`K8!lAxucq~MWQEyf@)Gr%yxD_+hI^M2C);uj$t zVDuY4wL9JGX*_-Mwl^yrVD*N5a&YMLy*LW~ zrOyhDaPYVtu}7XfkcTe~>1~&xqAz`A=O5J`x^EAf-+jZpNw=@Q)U9?XX5**Y_WetC zM2BO3ly;=?!{x~KClq681A$XAX~R02oy8y_8ESUL^%x+gQcx^(>L(^rK=HG+{WF4E z8N1$~lw1eUc?1&^s^h3t-b0+XD#Z+@`~fUMj|4xOW5jw%|^wP05vigiIC0bLlIG;jg!SQAktZD z>p+Sc*i%T#2{<~gAf@&cX}f1^R|kaPj%8;JS~LgWrLDeq{Y2~4k@Y}pYz+6D>lEs6 z<1u{{fS~Fl7Gk1_{T#@}ScC{D#CrX28743>5}u5ZvB@5?8S6VUuy=*VQdA3=KN=#P zJxL^h#>%Q72*{hmT4yXfVA82T>3wEK)e4#qxQBNM<3h%;;6P3f^8R4A-ah+VaMF9n z%GI)qi%7KN^H6`Iyhr!@F^f#FM9o*ckmmRI`g^h@OQD z7l3q6RgSZ@gJ?*7s=%>F(e{S7rs-HKVB6H> zi*svqxxNbYTWLc5cD)IUbE`04uP?*;YJDNjQU5G?4xJ|RXpQ`h-fO)tz7;s`h4o^^ frZ2H5e5lKT|30+U#Hk>#FILEIO.;141 166968 +(FILECREATED " 6-Feb-2026 23:22:00" {WMEDLEY}FILEIO.;142 166519 :EDIT-BY rmk - :CHANGES-TO (FNS COPYFILE COPYCHARS) + :CHANGES-TO (FNS DIRECTORYNAME) - :PREVIOUS-DATE "24-Apr-2025 22:16:47" -{DSK}kaplan>Local>medley3.5>working-medley>sources>FILEIO.;139) + :PREVIOUS-DATE "12-Sep-2025 08:19:06" {WMEDLEY}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 diff --git a/sources/FILEIO.LCOM b/sources/FILEIO.LCOM index 2b24260f3601eb23b6008399cc25c6339808d601..d120ea24e37246efed78f3db67ff19949c783bbb 100644 GIT binary patch delta 273 zcmdn^jH%-p(}Zvl1v6c@)FfRa10yp9BV#KgBP#>LiP?JfMw$v-O30E123AIoCf>8Yvi>nVA||DpJy9Voq_$z3*`2};KI!jZ*Dj>);%+o(KSl7id#C5V5qv_%sd4pw@@D+1!TQ?dU{F); z%+o(KSl0!pOF_xVMAxyP2;vtbBP*bbP0W=PxT;-(y=!eki&Kk=?XnXKauW0GeDaeM zbL?_cQ*u%(jrC0J%JYk|GxO4QAtH9g`K3k4sl|36CwcnoSsNNNT28*ONP6=VMwN{K DtgBhi diff --git a/sources/IOCHAR b/sources/IOCHAR index ac4b8fe8..1458efc7 100644 --- a/sources/IOCHAR +++ b/sources/IOCHAR @@ -1,15 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "24-Aug-2025 11:45:37"  -{DSK}kaplan>Local>medley3.5>working-medley>sources>IOCHAR.;49 100320 +(FILECREATED " 5-Feb-2026 10:06:08" {WMEDLEY}IOCHAR.;56 113942 :EDIT-BY rmk - :CHANGES-TO (RESOURCES \FFDELTA1) - (FNS MAKEBITTABLE \SETUP.FFILEPOS) + :CHANGES-TO (FNS FILEPOS FFILEPOS) + (MACROS \CATRANSLATE) + (VARS IOCHARCOMS) - :PREVIOUS-DATE "24-Apr-2025 22:08:18" -{DSK}kaplan>Local>medley3.5>working-medley>sources>IOCHAR.;48) + :PREVIOUS-DATE " 3-Feb-2026 10:00:18" {WMEDLEY}IOCHAR.;51) (PRETTYCOMPRINT IOCHARCOMS) @@ -74,96 +73,468 @@ (DEFINEQ (CHCON -(LAMBDA (X FLG RDTBL) (* bvm%: "24-Mar-86 16:29") (PROG (BASE OFFST LEN \CHCONLST \CHCONLSTAIL FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (\GETBASECHAR FATP BASE I))) SLOWCASE (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (* ; "Open code COLLECT") (COND (\CHCONLSTAIL (FRPLACD \CHCONLSTAIL (SETQ \CHCONLSTAIL (LIST CODE)))) (T (SETQ \CHCONLST (SETQ \CHCONLSTAIL (LIST CODE))))))) X FLG RDTBL) (RETURN \CHCONLST))) -) + [LAMBDA (X FLG RDTBL) (* bvm%: "24-Mar-86 16:29") + (PROG (BASE OFFST LEN \CHCONLST \CHCONLSTAIL FATP) + (COND + (FLG (GO SLOWCASE))) + (COND + ((LITATOM X) + (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) + (SETQ OFFST 1) + (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) + (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) + ((STRINGP X) + (SETQ BASE (ffetch (STRINGP BASE) of X)) + (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) + (SETQ OFFST (ffetch (STRINGP OFFST) of X)) + (SETQ LEN (ffetch (STRINGP LENGTH) of X))) + (T (GO SLOWCASE))) + (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (\GETBASECHAR FATP BASE I))) + SLOWCASE + (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CODE) (* ; "Open code COLLECT") + (COND + [\CHCONLSTAIL (FRPLACD \CHCONLSTAIL (SETQ \CHCONLSTAIL + (LIST CODE] + (T (SETQ \CHCONLST (SETQ \CHCONLSTAIL (LIST CODE] + X FLG RDTBL) + (RETURN \CHCONLST]) (UNPACK -(LAMBDA (X FLG RDTBL) (* bvm%: "24-Mar-86 16:29") (PROG (BASE OFFST LEN \CHCONLST \CHCONLSTAIL FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (FCHARACTER (\GETBASECHAR FATP BASE I)))) SLOWCASE (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (SETQ CODE (FCHARACTER CODE)) (* ; "Open code COLLECT") (COND (\CHCONLSTAIL (FRPLACD \CHCONLSTAIL (SETQ \CHCONLSTAIL (LIST CODE)))) (T (SETQ \CHCONLST (SETQ \CHCONLSTAIL (LIST CODE))))))) X FLG RDTBL) (RETURN \CHCONLST))) -) + [LAMBDA (X FLG RDTBL) (* bvm%: "24-Mar-86 16:29") + (PROG (BASE OFFST LEN \CHCONLST \CHCONLSTAIL FATP) + (COND + (FLG (GO SLOWCASE))) + (COND + ((LITATOM X) + (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) + (SETQ OFFST 1) + (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) + (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) + ((STRINGP X) + (SETQ BASE (ffetch (STRINGP BASE) of X)) + (SETQ OFFST (ffetch (STRINGP OFFST) of X)) + (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) + (SETQ LEN (ffetch (STRINGP LENGTH) of X))) + (T (GO SLOWCASE))) + [RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (FCHARACTER (\GETBASECHAR FATP + BASE I] + SLOWCASE + (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CODE) + (SETQ CODE (FCHARACTER CODE)) + (* ; "Open code COLLECT") + (COND + [\CHCONLSTAIL (FRPLACD \CHCONLSTAIL (SETQ \CHCONLSTAIL + (LIST CODE] + (T (SETQ \CHCONLST (SETQ \CHCONLSTAIL (LIST CODE] + X FLG RDTBL) + (RETURN \CHCONLST]) (DCHCON -(LAMBDA (X SCRATCHLIST FLG RDTBL) (* ; "Edited 24-Dec-86 14:04 by jds") (* ;;; "Unpack the character codes that make up the print-representation of X into the scratch list SCRATCHLIST. If FLG, use the PRIN2-pname. Do the printing according to RDTBL readtable, if supplied.") (SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (* ; "LITATOM case: Set up the indexing info for the \GETBASECHAR loop below.") (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (* ; "STRING case: Set up the indexing info for the \GETBASECHAR loop below.") (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) do (* ;; "Copy the characters from the string/atom-pname into the list") (ADDTOSCRATCHLIST (\GETBASECHAR FATP BASE I)))) SLOWCASE (* ;; "Slow case: Use \MAPPNAME to generate the characters, and grab onto them.") (RETURN (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (ADDTOSCRATCHLIST CODE))) X FLG RDTBL))))) -) + [LAMBDA (X SCRATCHLIST FLG RDTBL) (* ; "Edited 24-Dec-86 14:04 by jds") + +(* ;;; "Unpack the character codes that make up the print-representation of X into the scratch list SCRATCHLIST. If FLG, use the PRIN2-pname. Do the printing according to RDTBL readtable, if supplied.") + + (SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN FATP) + (COND + (FLG (GO SLOWCASE))) + (COND + ((LITATOM X) (* ; + "LITATOM case: Set up the indexing info for the \GETBASECHAR loop below.") + (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) + (SETQ OFFST 1) + (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) + (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) + ((STRINGP X) (* ; + "STRING case: Set up the indexing info for the \GETBASECHAR loop below.") + (SETQ BASE (ffetch (STRINGP BASE) of X)) + (SETQ OFFST (ffetch (STRINGP OFFST) of X)) + (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) + (SETQ LEN (ffetch (STRINGP LENGTH) of X))) + (T (GO SLOWCASE))) + [RETURN (for I from OFFST to (IPLUS OFFST LEN -1) + do + (* ;; + "Copy the characters from the string/atom-pname into the list") + + (ADDTOSCRATCHLIST (\GETBASECHAR FATP BASE I] + SLOWCASE + + + (* ;; + "Slow case: Use \MAPPNAME to generate the characters, and grab onto them.") + + (RETURN (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CODE) + (ADDTOSCRATCHLIST CODE] + X FLG RDTBL]) (DUNPACK -(LAMBDA (X SCRATCHLIST FLG RDTBL) (* bvm%: "24-Mar-86 16:30") (SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) do (ADDTOSCRATCHLIST (FCHARACTER (\GETBASECHAR FATP BASE I))))) SLOWCASE (RETURN (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (ADDTOSCRATCHLIST (FCHARACTER CODE)))) X FLG RDTBL))))) -) + [LAMBDA (X SCRATCHLIST FLG RDTBL) (* bvm%: "24-Mar-86 16:30") + (SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN FATP) + (COND + (FLG (GO SLOWCASE))) + (COND + ((LITATOM X) + (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) + (SETQ OFFST 1) + (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) + (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) + ((STRINGP X) + (SETQ BASE (ffetch (STRINGP BASE) of X)) + (SETQ OFFST (ffetch (STRINGP OFFST) of X)) + (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) + (SETQ LEN (ffetch (STRINGP LENGTH) of X))) + (T (GO SLOWCASE))) + [RETURN (for I from OFFST to (IPLUS OFFST LEN -1) + do (ADDTOSCRATCHLIST (FCHARACTER (\GETBASECHAR FATP + BASE I] + SLOWCASE + (RETURN (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CODE) + (ADDTOSCRATCHLIST (FCHARACTER + CODE] + X FLG RDTBL]) ) (DEFINEQ (UALPHORDER -(LAMBDA (ARG1 B) (* rmk%: " 2-Apr-85 11:20") (ALPHORDER ARG1 B UPPERCASEARRAY))) + [LAMBDA (ARG1 B) (* rmk%: " 2-Apr-85 11:20") + (ALPHORDER ARG1 B UPPERCASEARRAY]) (ALPHORDER -(LAMBDA (A B CASEARRAY) (* rmk%: "27-Mar-85 17:43") (DECLARE (GLOBALVARS \TRANSPARENT)) (PROG (CABASE ABASE ALEN AOFFSET AFATP BBASE BLEN BOFFSET BFATP C1 C2) (COND ((LITATOM A) (SETQ ABASE (ffetch (LITATOM PNAMEBASE) of A)) (SETQ AOFFSET 1) (SETQ ALEN (ffetch (LITATOM PNAMELENGTH) of A)) (SETQ AFATP (ffetch (LITATOM FATPNAMEP) of A))) ((STRINGP A) (SETQ ABASE (ffetch (STRINGP BASE) of A)) (SETQ AOFFSET (ffetch (STRINGP OFFST) of A)) (SETQ ALEN (ffetch (STRINGP LENGTH) of A)) (SETQ AFATP (ffetch (STRINGP FATSTRINGP) of A))) (T (RETURN (COND ((NUMBERP A) (* ; "Numbers are less than all other types") (OR (NOT (NUMBERP B)) (NOT (GREATERP A B)))) ((OR (NUMBERP B) (LITATOM B) (STRINGP B)) NIL) (T T))))) (COND ((LITATOM B) (SETQ BBASE (ffetch (LITATOM PNAMEBASE) of B)) (SETQ BOFFSET 1) (SETQ BLEN (ffetch (LITATOM PNAMELENGTH) of B)) (SETQ BFATP (ffetch (LITATOM FATPNAMEP) of B))) ((STRINGP B) (SETQ BBASE (ffetch (STRINGP BASE) of B)) (SETQ BOFFSET (ffetch (STRINGP OFFST) of B)) (SETQ BLEN (ffetch (STRINGP LENGTH) of B)) (SETQ BFATP (ffetch (STRINGP FATSTRINGP) of B))) (T (* ; "Only numbers are 'less than' atoms and strings") (RETURN (NOT (NUMBERP B))))) (SETQ CABASE (fetch (ARRAYP BASE) of (SETQ CASEARRAY (\DTEST (OR CASEARRAY \TRANSPARENT) (QUOTE ARRAYP))))) (RETURN (for I (CAFAT _ (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))) (CASIZE _ (fetch (ARRAYP LENGTH) of CASEARRAY)) from 0 do (COND ((IGEQ I ALEN) (RETURN (COND ((EQ ALEN BLEN) (QUOTE EQUAL)) (T (QUOTE LESSP))))) ((IGEQ I BLEN) (RETURN NIL)) ((EQ (SETQ C1 (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR AFATP ABASE (IPLUS I AOFFSET)))) (SETQ C2 (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR BFATP BBASE (IPLUS I BOFFSET)))))) ((ILESSP C1 C2) (RETURN (QUOTE LESSP))) (T (* ; "Greater") (RETURN NIL))))))) -) + [LAMBDA (A B CASEARRAY) (* rmk%: "27-Mar-85 17:43") + (DECLARE (GLOBALVARS \TRANSPARENT)) + (PROG (CABASE ABASE ALEN AOFFSET AFATP BBASE BLEN BOFFSET BFATP C1 C2) + [COND + ((LITATOM A) + (SETQ ABASE (ffetch (LITATOM PNAMEBASE) of A)) + (SETQ AOFFSET 1) + (SETQ ALEN (ffetch (LITATOM PNAMELENGTH) of A)) + (SETQ AFATP (ffetch (LITATOM FATPNAMEP) of A))) + ((STRINGP A) + (SETQ ABASE (ffetch (STRINGP BASE) of A)) + (SETQ AOFFSET (ffetch (STRINGP OFFST) of A)) + (SETQ ALEN (ffetch (STRINGP LENGTH) of A)) + (SETQ AFATP (ffetch (STRINGP FATSTRINGP) of A))) + (T (RETURN (COND + [(NUMBERP A) (* ; + "Numbers are less than all other types") + (OR (NOT (NUMBERP B)) + (NOT (GREATERP A B] + ((OR (NUMBERP B) + (LITATOM B) + (STRINGP B)) + NIL) + (T T] + [COND + ((LITATOM B) + (SETQ BBASE (ffetch (LITATOM PNAMEBASE) of B)) + (SETQ BOFFSET 1) + (SETQ BLEN (ffetch (LITATOM PNAMELENGTH) of B)) + (SETQ BFATP (ffetch (LITATOM FATPNAMEP) of B))) + ((STRINGP B) + (SETQ BBASE (ffetch (STRINGP BASE) of B)) + (SETQ BOFFSET (ffetch (STRINGP OFFST) of B)) + (SETQ BLEN (ffetch (STRINGP LENGTH) of B)) + (SETQ BFATP (ffetch (STRINGP FATSTRINGP) of B))) + (T (* ; + "Only numbers are 'less than' atoms and strings") + (RETURN (NOT (NUMBERP B] + [SETQ CABASE (fetch (ARRAYP BASE) of (SETQ CASEARRAY (\DTEST (OR CASEARRAY \TRANSPARENT) + 'ARRAYP] + (RETURN (for I (CAFAT _ (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))) + (CASIZE _ (fetch (ARRAYP LENGTH) of CASEARRAY)) from 0 + do (COND + [(IGEQ I ALEN) + (RETURN (COND + ((EQ ALEN BLEN) + 'EQUAL) + (T 'LESSP] + ((IGEQ I BLEN) + (RETURN NIL)) + [(EQ [SETQ C1 (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR AFATP ABASE + (IPLUS I AOFFSET] + (SETQ C2 (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR BFATP BBASE + (IPLUS I BOFFSET] + ((ILESSP C1 C2) + (RETURN 'LESSP)) + (T (* ; "Greater") + (RETURN NIL]) (CONCAT -(LAMBDA N (* rmk%: "26-Mar-85 19:08") (PROG ((J N) (LEN 0) (POS 1) S NM FATSEENP) L1 (COND ((NEQ J 0) (COND ((STRINGP (SETQ NM (ARG N J))) (OR FATSEENP (SETQ FATSEENP (ffetch (STRINGP FATSTRINGP) of NM)))) ((LITATOM NM) (OR FATSEENP (SETQ FATSEENP (ffetch (LITATOM FATPNAMEP) of NM)))) (T (SETARG N J (SETQ NM (MKSTRING NM))) (OR FATSEENP (SETQ FATSEENP (ffetch (STRINGP FATSTRINGP) of NM))))) (SETQ LEN (IPLUS LEN (NCHARS NM))) (SETQ J (SUB1 J)) (GO L1))) (SETQ S (ALLOCSTRING LEN NIL NIL FATSEENP)) L2 (COND ((NEQ J N) (SETQ J (ADD1 J)) (RPLSTRING S POS (ARG N J)) (SETQ POS (IPLUS POS (NCHARS (ARG N J)))) (GO L2))) (RETURN S))) -) + [LAMBDA N (* rmk%: "26-Mar-85 19:08") + (PROG ((J N) + (LEN 0) + (POS 1) + S NM FATSEENP) + L1 (COND + ((NEQ J 0) + [COND + [(STRINGP (SETQ NM (ARG N J))) + (OR FATSEENP (SETQ FATSEENP (ffetch (STRINGP FATSTRINGP) of NM] + [(LITATOM NM) + (OR FATSEENP (SETQ FATSEENP (ffetch (LITATOM FATPNAMEP) of NM] + (T (SETARG N J (SETQ NM (MKSTRING NM))) + (OR FATSEENP (SETQ FATSEENP (ffetch (STRINGP FATSTRINGP) of NM] + (SETQ LEN (IPLUS LEN (NCHARS NM))) + (SETQ J (SUB1 J)) + (GO L1))) + (SETQ S (ALLOCSTRING LEN NIL NIL FATSEENP)) + L2 (COND + ((NEQ J N) + (SETQ J (ADD1 J)) + (RPLSTRING S POS (ARG N J)) + [SETQ POS (IPLUS POS (NCHARS (ARG N J] + (GO L2))) + (RETURN S]) (CONCATCODES -(LAMBDA (CHARCODES) (* bvm%: " 6-May-84 21:56") (PROG ((STR (ALLOCSTRING (LENGTH CHARCODES)))) (for X in CHARCODES as I from 1 do (RPLCHARCODE STR I X)) (RETURN STR))) -) + [LAMBDA (CHARCODES) (* bvm%: " 6-May-84 21:56") + (PROG [(STR (ALLOCSTRING (LENGTH CHARCODES] + (for X in CHARCODES as I from 1 do (RPLCHARCODE STR I X)) + (RETURN STR]) (PACKC - [LAMBDA (X) (* ; "Edited 11-Nov-2018 12:12 by rmk:") - (* rmk%: "11-Apr-85 15:35") + [LAMBDA (X) (* ; "Edited 11-Nov-2018 12:12 by rmk:") + (* rmk%: "11-Apr-85 15:35") - (* ;; "Takes character codes in X, stuffs them into the \PNAMESTRING, and then calls \MKATOM.") + (* ;; "Takes character codes in X, stuffs them into the \PNAMESTRING, and then calls \MKATOM.") - (* ;; "The previous version uses HASFAT as the storage format even if the characters turned out to be all thin. For unknown reasons, this caused existing atoms not to be matched if they had non-ascii thin characters, even") + (* ;; "The previous version uses HASFAT as the storage format even if the characters turned out to be all thin. For unknown reasons, this caused existing atoms not to be matched if they had non-ascii thin characters, even") - (* ;; " though \MKATOM tried to figure out what the truth.") + (* ;; " though \MKATOM tried to figure out what the truth.") - (* ;; "But that was a bad optimization, involved an extra pass in every case. Better to start by assuming thin (0-255) characters and store them as bytes, then upgrade the storage format when the first fat code is seen. No extra work for the most common 0-255. If a code is outside of that range (e.g. Japanese), chances are that it will appear early in the sequence, so little work to be done to expand the storage format for previously stored characters.") + (* ;; "But that was a bad optimization, involved an extra pass in every case. Better to start by assuming thin (0-255) characters and store them as bytes, then upgrade the storage format when the first fat code is seen. No extra work for the most common 0-255. If a code is outside of that range (e.g. Japanese), chances are that it will appear early in the sequence, so little work to be done to expand the storage format for previously stored characters.") - (* ;; "The end-result: the storage format and characters are always consistent, HASFAT is accurate for both, and \MKATOM doesn't have to second-guess.") + (* ;; "The end-result: the storage format and characters are always consistent, HASFAT is accurate for both, and \MKATOM doesn't have to second-guess.") - (* ;; "Note: after init, the code for \MKATOM is in PACKAGE-STARTUP ") + (* ;; "Note: after init, the code for \MKATOM is in PACKAGE-STARTUP ") (WITH-RESOURCE (\PNAMESTRING) - (BIND HASFAT (PBASE _ (ffetch (STRINGP XBASE) of \PNAMESTRING)) for N - from 0 as C in X - do (AND (IGREATERP N \PNAMELIMIT) - (LISPERROR "ATOM TOO LONG")) - (IF HASFAT - THEN + (BIND HASFAT (PBASE _ (ffetch (STRINGP XBASE) of \PNAMESTRING)) for N from 0 as C + in X do (AND (IGREATERP N \PNAMELIMIT) + (LISPERROR "ATOM TOO LONG")) + (IF HASFAT + THEN + (* ;; + "We already saw a fat, and upgraded the storage format. Continue") - (* ;; - "We already saw a fat, and upgraded the storage format. Continue") + (\PUTBASEFAT PBASE N C) + ELSEIF (ILEQ C \MAXTHINCHAR) + THEN + (* ;; "Still seeing only thin characters. Continue") - (\PUTBASEFAT PBASE N C) - ELSEIF (ILEQ C \MAXTHINCHAR) - THEN + (\PUTBASETHIN PBASE N C) + ELSE + (* ;; "First fat, perhaps there are previous thins to convert. Go backwards so we don't smash the early ones") - (* ;; "Still seeing only thin characters. Continue") - - (\PUTBASETHIN PBASE N C) - ELSE - - (* ;; "First fat, perhaps there are previous thins to convert. Go backwards so we don't smash the early ones") - - (for NN from (SUB1 N) to 0 by -1 - DO (\PUTBASEFAT PBASE NN (\GETBASETHIN PBASE NN))) - (\PUTBASEFAT PBASE N C) - (SETQ HASFAT T)) finally (RETURN (\MKATOM PBASE 0 N HASFAT]) + (for NN from (SUB1 N) to 0 by -1 DO (\PUTBASEFAT PBASE NN + (\GETBASETHIN PBASE NN))) + (\PUTBASEFAT PBASE N C) + (SETQ HASFAT T)) finally (RETURN (\MKATOM PBASE 0 N HASFAT]) (PACK -(LAMBDA (X) (* ; "Edited 21-Mar-88 15:29 by bvm") (AND X (NLISTP X) (\ILLEGAL.ARG X)) (DECLARE (SPECVARS PACK.INDEX \PNAMESTRING)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((PACK.INDEX 1) ITEM) LP (COND ((NULL X) (RETURN (\MKATOM (fetch (STRINGP XBASE) of \PNAMESTRING) 0 (SUB1 PACK.INDEX) \FATPNAMESTRINGP)))) (COND ((OR (STRINGP (SETQ ITEM (CAR X))) (LITATOM ITEM)) (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) ITEM)) (T (\PACK.ITEM ITEM))) (SETQ X (LISTP (CDR X))) (GO LP)))) -) + [LAMBDA (X) (* ; "Edited 21-Mar-88 15:29 by bvm") + (AND X (NLISTP X) + (\ILLEGAL.ARG X)) + (DECLARE (SPECVARS PACK.INDEX \PNAMESTRING)) + (WITH-RESOURCE (\PNAMESTRING) + (PROG ((PACK.INDEX 1) + ITEM) + LP [COND + ((NULL X) + (RETURN (\MKATOM (fetch (STRINGP XBASE) of \PNAMESTRING) + 0 + (SUB1 PACK.INDEX) + \FATPNAMESTRINGP] + (COND + ((OR (STRINGP (SETQ ITEM (CAR X))) + (LITATOM ITEM)) + (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX + (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) + (ADD1 \PNAMELIMIT)) + (LISPERROR "ATOM TOO LONG"))) + ITEM)) + (T (\PACK.ITEM ITEM))) + (SETQ X (LISTP (CDR X))) + (GO LP]) (PACK* -(LAMBDA U (* ; "Edited 21-Mar-88 15:29 by bvm") (DECLARE (SPECVARS PACK.INDEX \PNAMESTRING)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((PACK.INDEX 1) (M 1) ITEM) LP (COND ((IGREATERP M U) (RETURN (\MKATOM (fetch (STRINGP XBASE) of \PNAMESTRING) 0 (SUB1 PACK.INDEX) \FATPNAMESTRINGP)))) (SETQ ITEM (ARG U M)) (COND ((AND (NULL *PACKAGE*) (LITATOM ITEM)) (* ;; "If we're in that nasty region of the INIT process before packages have been turned on, then we want to be careful to strip off any pseudo-package prefixes in the symbol's pname. We use the utility NAMESTRING-CONVERSION-CLAUSE from LLPACKAGE for this search.") (LET* ((BASE (ffetch (CL:SYMBOL PNAMEBASE) of ITEM)) (LEN (ffetch (CL:SYMBOL PNAMELENGTH) of ITEM)) (FATP (ffetch (CL:SYMBOL FATPNAMEP) of ITEM)) (CLAUSE (NAMESTRING-CONVERSION-CLAUSE BASE 1 LEN FATP))) (COND ((NULL CLAUSE) (* ; "Nothing special to do; this symbol didn't match any of the conversion clauses.") (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) ITEM)) (T (* ; "The symbol matched a clause. We should use only that part of the symbol that comes after the matching prefix.") (LET ((PREFIX-LENGTH (ffetch (STRINGP LENGTH) (CL:FIRST CLAUSE)))) (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (IDIFFERENCE (NCHARS ITEM) PREFIX-LENGTH)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) (SUBSTRING ITEM (IPLUS 1 PREFIX-LENGTH)))))))) ((OR (STRINGP ITEM) (LITATOM ITEM)) (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) ITEM)) (T (\PACK.ITEM ITEM))) (SETQ M (ADD1 M)) (GO LP)))) -) + [LAMBDA U (* ; "Edited 21-Mar-88 15:29 by bvm") + (DECLARE (SPECVARS PACK.INDEX \PNAMESTRING)) + (WITH-RESOURCE + (\PNAMESTRING) + (PROG ((PACK.INDEX 1) + (M 1) + ITEM) + LP [COND + ((IGREATERP M U) + (RETURN (\MKATOM (fetch (STRINGP XBASE) of \PNAMESTRING) + 0 + (SUB1 PACK.INDEX) + \FATPNAMESTRINGP] + (SETQ ITEM (ARG U M)) + (COND + [(AND (NULL *PACKAGE*) + (LITATOM ITEM)) + + (* ;; "If we're in that nasty region of the INIT process before packages have been turned on, then we want to be careful to strip off any pseudo-package prefixes in the symbol's pname. We use the utility NAMESTRING-CONVERSION-CLAUSE from LLPACKAGE for this search.") + + (LET* ((BASE (ffetch (CL:SYMBOL PNAMEBASE) of ITEM)) + (LEN (ffetch (CL:SYMBOL PNAMELENGTH) of ITEM)) + (FATP (ffetch (CL:SYMBOL FATPNAMEP) of ITEM)) + (CLAUSE (NAMESTRING-CONVERSION-CLAUSE BASE 1 LEN FATP))) + (COND + ((NULL CLAUSE) (* ; + "Nothing special to do; this symbol didn't match any of the conversion clauses.") + (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX + (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) + (ADD1 \PNAMELIMIT)) + (LISPERROR "ATOM TOO LONG"))) + ITEM)) + (T (* ; "The symbol matched a clause. We should use only that part of the symbol that comes after the matching prefix.") + (LET [(PREFIX-LENGTH (ffetch (STRINGP LENGTH) + (CL:FIRST CLAUSE] + (RPLSTRING \PNAMESTRING + (PROG1 PACK.INDEX + (AND (IGREATERP (add PACK.INDEX (IDIFFERENCE (NCHARS + ITEM) + PREFIX-LENGTH)) + (ADD1 \PNAMELIMIT)) + (LISPERROR "ATOM TOO LONG"))) + (SUBSTRING ITEM (IPLUS 1 PREFIX-LENGTH] + ((OR (STRINGP ITEM) + (LITATOM ITEM)) + (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX + (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) + (ADD1 \PNAMELIMIT)) + (LISPERROR "ATOM TOO LONG"))) + ITEM)) + (T (\PACK.ITEM ITEM))) + (SETQ M (ADD1 M)) + (GO LP]) (\PACK.ITEM -(LAMBDA (ITEM) (* ; "Edited 21-Mar-88 15:30 by bvm") (DECLARE (USEDFREE PACK.INDEX \PNAMESTRING)) (* ;;; "Slow case for PACK and PACK* -- append characters of ITEM to \PNAMESTRING, updating PACK.INDEX accordingly") (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (AND (IGREATERP PACK.INDEX \PNAMELIMIT) (LISPERROR "ATOM TOO LONG")) (\PNAMESTRINGPUTCHAR (fetch (STRINGP BASE) of \PNAMESTRING) (SUB1 PACK.INDEX) CODE) (add PACK.INDEX 1))) ITEM)) -) + [LAMBDA (ITEM) (* ; "Edited 21-Mar-88 15:30 by bvm") + (DECLARE (USEDFREE PACK.INDEX \PNAMESTRING)) + +(* ;;; "Slow case for PACK and PACK* -- append characters of ITEM to \PNAMESTRING, updating PACK.INDEX accordingly") + + (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CODE) + (AND (IGREATERP PACK.INDEX \PNAMELIMIT) + (LISPERROR "ATOM TOO LONG")) + (\PNAMESTRINGPUTCHAR (fetch (STRINGP BASE) of \PNAMESTRING) + (SUB1 PACK.INDEX) + CODE) + (add PACK.INDEX 1] + ITEM]) (STRPOS -(LAMBDA (PAT STRING START SKIP ANCHOR TAIL CASEARRAY BACKWARDSFLG) (* ; "Edited 6-Jan-88 12:44 by jds") (DECLARE (GLOBALVARS \TRANSPARENT)) (PROG (PATLEN PATBASE PATOFFST STRINGLEN STRINGBASE STRINGOFFST MAXI JMAX 1stPATchar jthPATchar STRFAT PATFAT) (COND ((LITATOM PAT) (SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PAT)) (SETQ PATOFFST 1) (SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PAT)) (SETQ PATFAT (fetch (LITATOM FATPNAMEP) of PAT))) (T (OR (STRINGP PAT) (SETQ PAT (MKSTRING PAT))) (SETQ PATBASE (fetch (STRINGP BASE) of PAT)) (SETQ PATOFFST (fetch (STRINGP OFFST) of PAT)) (SETQ PATLEN (fetch (STRINGP LENGTH) of PAT)) (SETQ PATFAT (fetch (STRINGP FATSTRINGP) of PAT)))) (COND ((LITATOM STRING) (SETQ STRINGBASE (fetch (LITATOM PNAMEBASE) of STRING)) (SETQ STRINGOFFST 1) (SETQ STRINGLEN (fetch (LITATOM PNAMELENGTH) of STRING)) (SETQ STRFAT (fetch (LITATOM FATPNAMEP) of STRING))) (T (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (SETQ STRINGBASE (fetch (STRINGP BASE) of STRING)) (SETQ STRINGOFFST (fetch (STRINGP OFFST) of STRING)) (SETQ STRINGLEN (fetch (STRINGP LENGTH) of STRING)) (SETQ STRFAT (fetch (STRINGP FATSTRINGP) of STRING)))) (COND ((IGEQ 0 (SETQ MAXI (ADD1 (IDIFFERENCE STRINGLEN PATLEN)))) (* ; "Who's he kidding? The PATTERN length is greater than the STRING length") (RETURN))) (COND ((NULL START) (SETQ START (COND (BACKWARDSFLG MAXI) (T 1)))) ((ILESSP START 0) (add START (ADD1 STRINGLEN)) (COND ((ILESSP START 1) (RETURN)))) ((IGREATERP START MAXI) (RETURN))) (* ; "Normalize start to a 1-origin index between 1 and LEN") (COND ((ILEQ PATLEN 0) (RETURN (AND TAIL START)))) (* ; "Null pattern matches anything -- but (STRPOS %"%" %"%") is NIL unless TAIL is T.") (AND SKIP (SETQ SKIP (CHCON1 SKIP))) (COND ((NULL CASEARRAY) (SETQ CASEARRAY \TRANSPARENT)) ((NOT (AND (ARRAYP CASEARRAY) (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of CASEARRAY)) (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))))) (\ILLEGAL.ARG CASEARRAY))) (* ; "Oh, for a LET here!") (add STRINGOFFST -1) (add PATOFFST -1) (RETURN (PROG ((CAOFFST (fetch (ARRAYP OFFST) of CASEARRAY)) (CABASE (fetch (ARRAYP BASE) of CASEARRAY)) (CAFAT (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))) (CASIZE (fetch (ARRAYP LENGTH) of CASEARRAY)) (OFFST.I (IPLUS STRINGOFFST START (COND (BACKWARDSFLG 1) (T -1)))) (LASTI (IPLUS STRINGOFFST (COND (ANCHOR START) (BACKWARDSFLG 1) (T MAXI)))) (JSTART (IPLUS PATOFFST 2)) (JMAX (IPLUS PATOFFST PATLEN))) (* ; "Remember! START is a 1-origin index") (* ; "There will be at least one pass thru the following loop, or else we would have (RETURN) before now") (OR (EQ 0 CAOFFST) (ERROR "CASEARRAY can't be a sub-array: " CASEARRAY)) (SETQ 1stPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR PATFAT PATBASE (ADD1 PATOFFST)))) LP (COND ((COND (BACKWARDSFLG (ILESSP (add OFFST.I -1) LASTI)) (T (IGREATERP (add OFFST.I 1) LASTI))) (RETURN)) ((AND (OR (EQ 1stPATchar SKIP) (EQ 1stPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR STRFAT STRINGBASE OFFST.I)))) (for J from JSTART to JMAX as K from (ADD1 OFFST.I) always (OR (EQ SKIP (SETQ jthPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR PATFAT PATBASE J)))) (EQ jthPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR STRFAT STRINGBASE K)))))) (RETURN (IDIFFERENCE (COND (TAIL (IPLUS OFFST.I PATLEN)) (T OFFST.I)) STRINGOFFST)))) (GO LP) (* ; "Fall out thru bottom if didn't find it"))))) -) + [LAMBDA (PAT STRING START SKIP ANCHOR TAIL CASEARRAY BACKWARDSFLG) + (* ; "Edited 6-Jan-88 12:44 by jds") + (DECLARE (GLOBALVARS \TRANSPARENT)) + (PROG (PATLEN PATBASE PATOFFST STRINGLEN STRINGBASE STRINGOFFST MAXI JMAX 1stPATchar jthPATchar + STRFAT PATFAT) + [COND + ((LITATOM PAT) + (SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PAT)) + (SETQ PATOFFST 1) + (SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PAT)) + (SETQ PATFAT (fetch (LITATOM FATPNAMEP) of PAT))) + (T (OR (STRINGP PAT) + (SETQ PAT (MKSTRING PAT))) + (SETQ PATBASE (fetch (STRINGP BASE) of PAT)) + (SETQ PATOFFST (fetch (STRINGP OFFST) of PAT)) + (SETQ PATLEN (fetch (STRINGP LENGTH) of PAT)) + (SETQ PATFAT (fetch (STRINGP FATSTRINGP) of PAT] + [COND + ((LITATOM STRING) + (SETQ STRINGBASE (fetch (LITATOM PNAMEBASE) of STRING)) + (SETQ STRINGOFFST 1) + (SETQ STRINGLEN (fetch (LITATOM PNAMELENGTH) of STRING)) + (SETQ STRFAT (fetch (LITATOM FATPNAMEP) of STRING))) + (T (OR (STRINGP STRING) + (SETQ STRING (MKSTRING STRING))) + (SETQ STRINGBASE (fetch (STRINGP BASE) of STRING)) + (SETQ STRINGOFFST (fetch (STRINGP OFFST) of STRING)) + (SETQ STRINGLEN (fetch (STRINGP LENGTH) of STRING)) + (SETQ STRFAT (fetch (STRINGP FATSTRINGP) of STRING] + (COND + ([IGEQ 0 (SETQ MAXI (ADD1 (IDIFFERENCE STRINGLEN PATLEN] + (* ; + "Who's he kidding? The PATTERN length is greater than the STRING length") + (RETURN))) + (COND + [(NULL START) + (SETQ START (COND + (BACKWARDSFLG MAXI) + (T 1] + [(ILESSP START 0) + (add START (ADD1 STRINGLEN)) + (COND + ((ILESSP START 1) + (RETURN] + ((IGREATERP START MAXI) + (RETURN))) (* ; + "Normalize start to a 1-origin index between 1 and LEN") + [COND + ((ILEQ PATLEN 0) + (RETURN (AND TAIL START] (* ; + "Null pattern matches anything -- but (STRPOS %"%" %"%") is NIL unless TAIL is T.") + (AND SKIP (SETQ SKIP (CHCON1 SKIP))) + (COND + ((NULL CASEARRAY) + (SETQ CASEARRAY \TRANSPARENT)) + ([NOT (AND (ARRAYP CASEARRAY) + (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of CASEARRAY)) + (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY] + (\ILLEGAL.ARG CASEARRAY))) (* ; "Oh, for a LET here!") + (add STRINGOFFST -1) + (add PATOFFST -1) + (RETURN (PROG ((CAOFFST (fetch (ARRAYP OFFST) of CASEARRAY)) + (CABASE (fetch (ARRAYP BASE) of CASEARRAY)) + (CAFAT (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))) + (CASIZE (fetch (ARRAYP LENGTH) of CASEARRAY)) + [OFFST.I (IPLUS STRINGOFFST START (COND + (BACKWARDSFLG 1) + (T -1] + [LASTI (IPLUS STRINGOFFST (COND + (ANCHOR START) + (BACKWARDSFLG 1) + (T MAXI] + (JSTART (IPLUS PATOFFST 2)) + (JMAX (IPLUS PATOFFST PATLEN))) (* ; + "Remember! START is a 1-origin index") + (* ; + "There will be at least one pass thru the following loop, or else we would have (RETURN) before now") + (OR (EQ 0 CAOFFST) + (ERROR "CASEARRAY can't be a sub-array: " CASEARRAY)) + [SETQ 1stPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR PATFAT + PATBASE + (ADD1 PATOFFST] + LP [COND + ((COND + (BACKWARDSFLG (ILESSP (add OFFST.I -1) + LASTI)) + (T (IGREATERP (add OFFST.I 1) + LASTI))) + (RETURN)) + ([AND [OR (EQ 1stPATchar SKIP) + (EQ 1stPATchar (\CATRANSLATE CABASE CASIZE CAFAT + (\GETBASECHAR STRFAT STRINGBASE OFFST.I] + (for J from JSTART to JMAX as K from (ADD1 OFFST.I) + always (OR [EQ SKIP (SETQ jthPATchar (\CATRANSLATE CABASE CASIZE + CAFAT + (\GETBASECHAR PATFAT + PATBASE J] + (EQ jthPATchar (\CATRANSLATE CABASE CASIZE CAFAT + (\GETBASECHAR STRFAT STRINGBASE + K] + (RETURN (IDIFFERENCE (COND + (TAIL (IPLUS OFFST.I PATLEN)) + (T OFFST.I)) + STRINGOFFST] + (GO LP) (* ; + "Fall out thru bottom if didn't find it") + ]) ) (CL:DEFUN XCL:PACK (NAMES &OPTIONAL (PACKAGE *PACKAGE*)) @@ -200,8 +571,59 @@ (DEFINEQ (STRPOSL -(LAMBDA (A STRING START NEG BACKWARDSFLG) (* edited%: "18-Mar-86 17:20") (* ;; "Given a list of charcodes, A, find the first one in STRING.") (GLOBALRESOURCE \STRPOSLARRAY (PROG (BASE OFFST LEN I LASTI STRFAT CH) (OR (type? CHARTABLE A) (SETQ A (MAKEBITTABLE A NIL \STRPOSLARRAY))) (if (LITATOM STRING) then (SETQ BASE (fetch (LITATOM PNAMEBASE) of STRING)) (SETQ LEN (fetch (LITATOM PNAMELENGTH) of STRING)) (SETQ OFFST 1) (SETQ STRFAT (fetch (LITATOM FATPNAMEP) of STRING)) else (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (SETQ BASE (fetch (STRINGP BASE) of STRING)) (SETQ LEN (fetch (STRINGP LENGTH) of STRING)) (SETQ OFFST (fetch (STRINGP OFFST) of STRING)) (SETQ STRFAT (fetch (STRINGP FATSTRINGP) of STRING))) (if (NULL START) then (SETQ START (if BACKWARDSFLG then LEN else 1)) elseif (ILESSP START 0) then (add START (ADD1 LEN)) (if (ILESSP START 1) then (RETURN)) elseif (IGREATERP START LEN) then (RETURN)) (* ; "Normalize start to a 1-origin index between 1 and LEN") (add OFFST -1) (* ; "Bias the OFFST since START is 1-origin and the loop deals in 0-origin") (SETQ NEG (if NEG then (* ; "Convert NEG to match the correct value returned by \SYNCODE") 0 else 1)) (SETQ I (IPLUS OFFST START)) (SETQ LASTI (IPLUS OFFST (if BACKWARDSFLG then (add I 1) 1 else (add I -1) LEN))) (* ; "There will be at least one pass thru the following loop, or else we would have (RETURN) before now") LP (if (if BACKWARDSFLG then (ILESSP (add I -1) LASTI) else (IGREATERP (add I 1) LASTI)) then (RETURN) elseif (EQ NEG (\SYNCODE A (\GETBASECHAR STRFAT BASE I))) then (RETURN (IDIFFERENCE I OFFST))) (GO LP)))) -) + [LAMBDA (A STRING START NEG BACKWARDSFLG) (* edited%: "18-Mar-86 17:20") + + (* ;; "Given a list of charcodes, A, find the first one in STRING.") + + (GLOBALRESOURCE \STRPOSLARRAY (PROG (BASE OFFST LEN I LASTI STRFAT CH) + (OR (type? CHARTABLE A) + (SETQ A (MAKEBITTABLE A NIL \STRPOSLARRAY))) + (if (LITATOM STRING) + then (SETQ BASE (fetch (LITATOM PNAMEBASE) of STRING)) + (SETQ LEN (fetch (LITATOM PNAMELENGTH) of STRING)) + (SETQ OFFST 1) + (SETQ STRFAT (fetch (LITATOM FATPNAMEP) of STRING)) + else (OR (STRINGP STRING) + (SETQ STRING (MKSTRING STRING))) + (SETQ BASE (fetch (STRINGP BASE) of STRING)) + (SETQ LEN (fetch (STRINGP LENGTH) of STRING)) + (SETQ OFFST (fetch (STRINGP OFFST) of STRING)) + (SETQ STRFAT (fetch (STRINGP FATSTRINGP) of STRING))) + (if (NULL START) + then (SETQ START (if BACKWARDSFLG + then LEN + else 1)) + elseif (ILESSP START 0) + then (add START (ADD1 LEN)) + (if (ILESSP START 1) + then (RETURN)) + elseif (IGREATERP START LEN) + then (RETURN)) (* ; + "Normalize start to a 1-origin index between 1 and LEN") + (add OFFST -1) (* ; + "Bias the OFFST since START is 1-origin and the loop deals in 0-origin") + (SETQ NEG (if NEG + then (* ; + "Convert NEG to match the correct value returned by \SYNCODE") + 0 + else 1)) + (SETQ I (IPLUS OFFST START)) + (SETQ LASTI (IPLUS OFFST (if BACKWARDSFLG + then (add I 1) + 1 + else (add I -1) + LEN))) + (* ; + "There will be at least one pass thru the following loop, or else we would have (RETURN) before now") + LP (if (if BACKWARDSFLG + then (ILESSP (add I -1) + LASTI) + else (IGREATERP (add I 1) + LASTI)) + then (RETURN) + elseif (EQ NEG (\SYNCODE A (\GETBASECHAR STRFAT BASE I))) + then (RETURN (IDIFFERENCE I OFFST))) + (GO LP]) (MAKEBITTABLE [LAMBDA (L NEG A) (* ; "Edited 24-Aug-2025 11:45 by rmk") @@ -229,12 +651,21 @@ (DEFINEQ (CASEARRAY -(LAMBDA (OLDAR) (* lmm "20-MAR-81 10:21") (COND (OLDAR (COPYARRAY OLDAR)) (T (PROG ((AR (ARRAY 256 (QUOTE BYTE) 0 0))) (for I from 0 to 255 do (SETA AR I I)) (RETURN AR))))) -) + [LAMBDA (OLDAR) (* lmm "20-MAR-81 10:21") + (COND + (OLDAR (COPYARRAY OLDAR)) + (T (PROG ((AR (ARRAY 256 'BYTE 0 0))) + (for I from 0 to 255 do (SETA AR I I)) + (RETURN AR]) (UPPERCASEARRAY -(LAMBDA NIL (* rmk%: " 2-Apr-85 11:22") (OR (ARRAYP UPPERCASEARRAY) (LET ((CA (CASEARRAY))) (for I from (CHARCODE a) to (CHARCODE z) do (SETCASEARRAY CA I (IDIFFERENCE I (CONSTANT (IDIFFERENCE (CHARCODE a) (CHARCODE A)))))) (SETQ UPPERCASEARRAY CA)))) -) + [LAMBDA NIL (* rmk%: " 2-Apr-85 11:22") + (OR (ARRAYP UPPERCASEARRAY) + (LET ((CA (CASEARRAY))) + [for I from (CHARCODE a) to (CHARCODE z) + do (SETCASEARRAY CA I (IDIFFERENCE I (CONSTANT (IDIFFERENCE (CHARCODE a) + (CHARCODE A] + (SETQ UPPERCASEARRAY CA]) ) (MOVD? 'SETA 'SETCASEARRAY) @@ -260,6 +691,10 @@ DONTCOPY (FILEPOS [LAMBDA (PATTERN FILE START END SKIP TAIL CASEARRAY) + (* ;; "Edited 5-Feb-2026 10:02 by rmk") + + (* ;; "Edited 3-Feb-2026 10:59 by rmk") + (* ;; "Edited 24-Apr-2025 22:08 by rmk") (* ;; "Edited 10-Jul-2022 16:51 by rmk") @@ -268,7 +703,7 @@ DONTCOPY (* ;; "Edited 25-Jun-2022 22:51 by rmk: The original version was a byte-level searcher, this upgrades to character searching as determined by the external format of the stream. (It is also a bit faster than the original).") - (* ;; "This provides accurate results if the stream's external format is stable, wherein each character code has a unique byte representation. If the stream's format is unstable (i.e. MCCS runcoding), then the result is accurate if the stream's initial charset (or other contextual information) is correct for the START byte position.") + (* ;; "This provides accurate results if the stream's external format is stable, wherein each character code has a unique byte representation. If the stream's format is unstable (i.e. XCCS runcoding vs 2-byte codes), then the result is accurate if the stream's initial charset (or other contextual information) is correct for the START byte position.") (* ;; "Otherwise, there may be some bad matches and some missing matches. The slow case will be accurate in those cases (and a NIL return for the format's \FORMATBYTESTRING function will kick it into the slow case (about 10 times slower). This always defers to the slow case if SKIP or CASEARRAY are non-NIL.") @@ -317,8 +752,12 @@ DONTCOPY (* ;; "Empty string: succed. Already positioned at STARTBYTEPOS") (RETURN STARTBYTEPOS)) - (CL:WHEN [OR CASEARRAY (AND SKIP (STRPOS SKIP PATTERN)) - (NOT (SETQ PATSTR (\FORMATBYTESTRING STREAM PATTERN] + (CL:WHEN [OR CASEARRAY (fetch (EXTERNALFORMAT UNSTABLE) of (FIND-FORMAT (STREAMPROP STREAM + + :EXTERNAL-FORMAT + ))) + (AND SKIP (STRPOS SKIP PATTERN)) + (NOT (SETQ PATSTR (MCCSTOFORMATBYTES STREAM PATTERN] (RETURN (OR (\SLOWFILEPOS PATTERN STREAM STARTBYTEPOS ENDBYTEPOS SKIP TAIL CASEARRAY) (GO FAILED)))) @@ -382,16 +821,11 @@ DONTCOPY FOUNDIT - (* ;; "The stream's charset should be set to the charset corresponding to the return byte-position. We haven't been tracking it, but if we are returning the tail pointer, then the stream's character set must be the same as the character set of the last character o fPATTERN.") - - (* ;; "Getting the character set for the start of the match is a little trickier. We know the character set at the byte that starts the beginning of the match (= character set of PATTERN's first character. If we set the stream to that charset, then back up one character, that should get it right. ") - - (* ;; "This should only be necessary for an unstable format, maybe don't bother if it isn't XCCS. There is another special case here for MCCS: if the charset is 255 at the start (=2 byte encoding), then we assume that it didn't change, and nothing to worry about.") + (* ;; "The stream's charset should be set to the charset corresponding to the return byte-position. We haven't been tracking it, but if we are returning the tail pointer, then the stream's character set must be the same as the character set of the last character of PATTERN. If returning the start, then the stream's charset must be the charset of the first character.") (RETURN (IF TAIL - THEN (CL:UNLESS (EQ NSCHARSETSHIFT (ffetch (STREAM CHARSET) of STREAM)) - (freplace (STREAM CHARSET) of STREAM with (\CHARSET (NTHCHARCODE - PATTERN -1)))) + THEN (freplace (STREAM CHARSET) of STREAM with (\CHARSET (NTHCHARCODE PATTERN + -1))) (CL:IF (EQ TAIL 'BOTH) (CONS (IDIFFERENCE (\GETFILEPTR STREAM) PATLEN) @@ -403,10 +837,8 @@ DONTCOPY (\INCFILEPTR STREAM (IMINUS PATLEN)) (SETQ STARTBYTEPOS (\GETFILEPTR STREAM)) - (CL:UNLESS (EQ NSCHARSETSHIFT (ffetch (STREAM CHARSET) of STREAM)) - (freplace (STREAM CHARSET) of STREAM with (\CHARSET (CHCON1 PATTERN))) - (\BACKCCODE STREAM) (* ; "Should fix the charset") - (\SETFILEPTR STREAM STARTBYTEPOS)) + (\SETFILEPTR STREAM STARTBYTEPOS) + (freplace (STREAM CHARSET) of STREAM with (\CHARSET (CHCON1 PATTERN))) STARTBYTEPOS)) FAILED (\SETFILEPTR STREAM ORGFILEPTR) (* ; @@ -416,6 +848,10 @@ DONTCOPY (FFILEPOS [LAMBDA (PATTERN FILE START END SKIP TAIL CASEARRAY) + (* ;; "Edited 5-Feb-2026 10:02 by rmk") + + (* ;; "Edited 3-Feb-2026 09:55 by rmk") + (* ;; "Edited 24-Apr-2025 22:07 by rmk") (* ;; "Edited 10-Jul-2022 10:17 by rmk") @@ -431,8 +867,13 @@ DONTCOPY (PROG ((STREAM (\GETSTREAM FILE 'INPUT)) BYTEPATTERN BPATBASE BPATOFFSET BPATLEN ORGFILEPTR STARTBYTEPOS ENDBYTEPOS BIGENDOFFSET STARTSEG ENDSEG EOF) - (CL:WHEN [OR SKIP CASEARRAY (NOT (fetch PAGEMAPPED of (fetch (STREAM DEVICE) of STREAM))) - (NULL (SETQ BYTEPATTERN (\FORMATBYTESTRING STREAM PATTERN] + (CL:WHEN [OR CASEARRAY (fetch (EXTERNALFORMAT UNSTABLE) of (FIND-FORMAT (STREAMPROP STREAM + + :EXTERNAL-FORMAT + ))) + (AND SKIP (STRPOS SKIP PATTERN)) + (NOT (fetch PAGEMAPPED of (fetch (STREAM DEVICE) of STREAM))) + (NULL (SETQ BYTEPATTERN (MCCSTOFORMATBYTES STREAM PATTERN] (* ; "Slow case--use FILEPOS") (GO TRYFILEPOS)) (* ;  "calculate start addr and set file ptr.") @@ -827,19 +1268,24 @@ DONTCOPY (DEFINEQ (DATE -(LAMBDA (FORMAT) (* raf "16-Oct-86 17:16") (\OUTDATE (\UNPACKDATE) FORMAT))) + [LAMBDA (FORMAT) (* raf "16-Oct-86 17:16") + (\OUTDATE (\UNPACKDATE) + FORMAT]) (DATEFORMAT -(NLAMBDA FORMAT (* raf "16-Oct-86 17:17") (CONS (QUOTE DATEFORMAT) FORMAT))) + [NLAMBDA FORMAT (* raf "16-Oct-86 17:17") + (CONS 'DATEFORMAT FORMAT]) (GDATE -(LAMBDA (DATE FORMAT STRPTR) (* raf "16-Oct-86 17:17") (\OUTDATE (\UNPACKDATE DATE) FORMAT STRPTR))) + [LAMBDA (DATE FORMAT STRPTR) (* raf "16-Oct-86 17:17") + (\OUTDATE (\UNPACKDATE DATE) + FORMAT STRPTR]) (IDATE - [LAMBDA (STR DEFAULTTIME) (* ; "Edited 17-Apr-2018 10:05 by rmk:") - (* ; "Edited 4-May-89 18:22 by bvm") + [LAMBDA (STR DEFAULTTIME) (* ; "Edited 17-Apr-2018 10:05 by rmk:") + (* ; "Edited 4-May-89 18:22 by bvm") - (* ;; "RMK: Fixed so that year < 100 heuristic is changed to add 2000 if < 50, 1900 if >= 50. Y2K guess for 2-digit years") + (* ;; "RMK: Fixed so that year < 100 heuristic is changed to add 2000 if < 50, 1900 if >= 50. Y2K guess for 2-digit years") (if (NULL STR) then (DAYTIME) @@ -851,16 +1297,16 @@ DONTCOPY TOP (OR (SETQ N1 (\IDATESCANTOKEN)) (RETURN NIL)) (SELCHARQ (NTHCHARCODE *STR* *POS*) - ((/ - SPACE) (* ; "Okay to put inside date") + ((/ - SPACE) (* ; "Okay to put inside date") (add *POS* 1)) ("," (if (LISTP N1) - then (* ; - "Assume str was something like Mon, Apr 1.... Trash the day.") - (add *POS* 1) - (GO TOP))) + then (* ; + "Assume str was something like Mon, Apr 1.... Trash the day.") + (add *POS* 1) + (GO TOP))) ("." (if (LISTP N1) - then (* ; "Abbreviated month?") - (add *POS* 1))) + then (* ; "Abbreviated month?") + (add *POS* 1))) NIL) (OR (SETQ N2 (\IDATESCANTOKEN)) (RETURN NIL)) @@ -868,52 +1314,52 @@ DONTCOPY ((/ - SPACE %,) (add *POS* 1)) ("." (if (LISTP N2) - then (* ; "Abbreviated month?") - (add *POS* 1))) + then (* ; "Abbreviated month?") + (add *POS* 1))) NIL) (if [NOT (FIXP (SETQ YEAR (\IDATESCANTOKEN] then (RETURN NIL) elseif (< YEAR 100) - then (* ; "Y2K heuristic") - (add YEAR (if (< YEAR 50) - THEN 2000 - ELSE 1900)) + then (* ; "Y2K heuristic") + (add YEAR (if (< YEAR 50) + THEN 2000 + ELSE 1900)) elseif (OR (< YEAR 1900) - (> YEAR 2037)) - then (* ; "out of range") - (RETURN NIL)) (* ; "Now figure out day and month") + (> YEAR 2037)) + then (* ; "out of range") + (RETURN NIL)) (* ; "Now figure out day and month") (if (FIXP N2) - then (* ; "Must be month-day") - (SETQ DAY N2) - (SETQ MONTH N1) + then (* ; "Must be month-day") + (SETQ DAY N2) + (SETQ MONTH N1) elseif (FIXP (SETQ DAY N1)) - then (* ; "day-month") - (SETQ MONTH N2) + then (* ; "day-month") + (SETQ MONTH N2) else (RETURN NIL)) (if (FIXP MONTH) then (if (OR (< MONTH 1) - (> MONTH 12)) - then (* ; "invalid month") - (RETURN NIL)) + (> MONTH 12)) + then (* ; "invalid month") + (RETURN NIL)) elseif (SETQ MONTH (\IDATE-PARSE-MONTH MONTH)) else (RETURN NIL)) (if (OR (< DAY 1) - (> DAY (SELECTQ MONTH - ((9 4 6 11) (* ; "30 days hath September...") - 30) - (2 (if (EVENP YEAR 4) - then 29 - else 28)) - 31))) + (> DAY (SELECTQ MONTH + ((9 4 6 11) (* ; "30 days hath September...") + 30) + (2 (if (EVENP YEAR 4) + then 29 + else 28)) + 31))) then (RETURN NIL)) (while (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) - (CHARCODE SPACE)) do (* ; "Skip spaces") - (add *POS* 1)) + (CHARCODE SPACE)) do (* ; "Skip spaces") + (add *POS* 1)) (SELCHARQ (NTHCHARCODE *STR* *POS*) - ("," (* ; "Ok to terminate date with comma") + ("," (* ; "Ok to terminate date with comma") (add *POS* 1)) - (NIL (* ; - "No time. Ok if DEFAULTTIME passed in") + (NIL (* ; + "No time. Ok if DEFAULTTIME passed in") (if (NULL DEFAULTTIME) then (RETURN NIL)) (SETQ SECONDS (IREMAINDER DEFAULTTIME 60)) @@ -923,63 +1369,60 @@ DONTCOPY (GO DONE)) NIL) - (* ;; "Now scan time") + (* ;; "Now scan time") (if [NOT (FIXP (SETQ HOUR (\IDATESCANTOKEN] then (RETURN NIL)) (if (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) - (CHARCODE %:)) - then (* ; "hh:mm") - (add *POS* 1) - (OR (FIXP (SETQ MINUTES (\IDATESCANTOKEN))) - (RETURN NIL)) - (if (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) - (CHARCODE %:)) - then (* ; "hh:mm:ss") - (add *POS* 1) - (OR (FIXP (SETQ SECONDS (\IDATESCANTOKEN))) - (RETURN NIL)) - (SETQ CH (NTHCHARCODE *STR* *POS*))) - else (* ; - "break apart time given without colon") - (SETQ MINUTES (IREMAINDER HOUR 100)) - (SETQ HOUR (IQUOTIENT HOUR 100))) + (CHARCODE %:)) + then (* ; "hh:mm") + (add *POS* 1) + (OR (FIXP (SETQ MINUTES (\IDATESCANTOKEN))) + (RETURN NIL)) + (if (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) + (CHARCODE %:)) + then (* ; "hh:mm:ss") + (add *POS* 1) + (OR (FIXP (SETQ SECONDS (\IDATESCANTOKEN))) + (RETURN NIL)) + (SETQ CH (NTHCHARCODE *STR* *POS*))) + else (* ; + "break apart time given without colon") + (SETQ MINUTES (IREMAINDER HOUR 100)) + (SETQ HOUR (IQUOTIENT HOUR 100))) [if CH - then (* ; "There's more") - [while (EQ CH (CHARCODE SPACE)) do (* ; "Skip spaces") - (SETQ CH (NTHCHARCODE *STR* - (add *POS* 1] + then (* ; "There's more") + [while (EQ CH (CHARCODE SPACE)) do (* ; "Skip spaces") + (SETQ CH (NTHCHARCODE *STR* (add *POS* 1] [if [AND (FMEMB CH (CHARCODE (A P a p))) - (FMEMB (NTHCHARCODE *STR* (ADD1 *POS*)) - (CHARCODE (M m))) - (FMEMB (NTHCHARCODE *STR* (+ *POS* 2)) - (CHARCODE (SPACE - NIL] - then (* ; "AM or PM appended") - (if (NOT (< HOUR 13)) - then (* ; "bogus") - (RETURN NIL)) - (if (EQ HOUR 12) - then (* ; "wrap to zero") - (SETQ HOUR 0)) - (if (FMEMB CH (CHARCODE (P p))) - then (* ; "PM = 12 hours later") - (add HOUR 12)) - (SETQ CH (NTHCHARCODE *STR* (add *POS* 2))) - (while (EQ CH (CHARCODE SPACE)) do - (* ; "Skip spaces") - (SETQ CH (NTHCHARCODE - *STR* - (add *POS* 1] + (FMEMB (NTHCHARCODE *STR* (ADD1 *POS*)) + (CHARCODE (M m))) + (FMEMB (NTHCHARCODE *STR* (+ *POS* 2)) + (CHARCODE (SPACE - NIL] + then (* ; "AM or PM appended") + (if (NOT (< HOUR 13)) + then (* ; "bogus") + (RETURN NIL)) + (if (EQ HOUR 12) + then (* ; "wrap to zero") + (SETQ HOUR 0)) + (if (FMEMB CH (CHARCODE (P p))) + then (* ; "PM = 12 hours later") + (add HOUR 12)) + (SETQ CH (NTHCHARCODE *STR* (add *POS* 2))) + (while (EQ CH (CHARCODE SPACE)) do (* ; "Skip spaces") + (SETQ CH (NTHCHARCODE *STR* + (add *POS* 1] - (* ;; "Now check for time zone") + (* ;; "Now check for time zone") [if [AND (EQ CH (CHARCODE -)) - (ALPHACHARP (NTHCHARCODE *STR* (ADD1 *POS*] - then (* ; - "Some obsolete date forms gave time zone separated from time by hyphen") - (SETQ CH (NTHCHARCODE *STR* (add *POS* 1] + (ALPHACHARP (NTHCHARCODE *STR* (ADD1 *POS*] + then (* ; + "Some obsolete date forms gave time zone separated from time by hyphen") + (SETQ CH (NTHCHARCODE *STR* (add *POS* 1] (SELCHARQ CH - ((+ -) (* ; "Explicit offset +-hhmm from GMT") + ((+ -) (* ; "Explicit offset +-hhmm from GMT") (add *POS* 1) (if [NOT (FIXP (SETQ TIMEZONE (\IDATESCANTOKEN] then (RETURN NIL)) @@ -987,40 +1430,39 @@ DONTCOPY (CL:TRUNCATE TIMEZONE 100) (SETQ TIMEZONE (if (EQ M 0) then H - else (* ; "Non-hour timezone. Use ratios.") - (+ H (/ M 60] + else (* ; "Non-hour timezone. Use ratios.") + (+ H (/ M 60] (if (EQ CH (CHARCODE +)) - then (* ; - "we represent time zones the other way around, so have to negate") - (SETQ TIMEZONE (- TIMEZONE)))) + then (* ; + "we represent time zones the other way around, so have to negate") + (SETQ TIMEZONE (- TIMEZONE)))) (if (AND CH (ALPHACHARP CH)) - then (* ; "Perhaps symbolic time zone") - (PROG ((START *POS*)) - LP (if [NULL (SETQ CH (NTHCHARCODE *STR* (add *POS* 1] - elseif (ALPHACHARP CH) - then (GO LP) - elseif (EQ CH (CHARCODE SPACE)) - then (* ; - "Space may terminate, except that some time zones have space in middle, e.g., EET DST.") - (if (AND (SETQ CH (NTHCHARCODE *STR* (ADD1 *POS*))) + then (* ; "Perhaps symbolic time zone") + (PROG ((START *POS*)) + LP (if [NULL (SETQ CH (NTHCHARCODE *STR* (add *POS* 1] + elseif (ALPHACHARP CH) + then (GO LP) + elseif (EQ CH (CHARCODE SPACE)) + then (* ; + "Space may terminate, except that some time zones have space in middle, e.g., EET DST.") + (if (AND (SETQ CH (NTHCHARCODE *STR* (ADD1 *POS*))) (ALPHACHARP CH)) - then (add *POS* 1) - (GO LP)) - else (* ; "Non-alphabetic in timezone") - (RETURN NIL)) + then (add *POS* 1) + (GO LP)) + else (* ; "Non-alphabetic in timezone") + (RETURN NIL)) - (* ;; "Potential time zone from START to before POS") + (* ;; "Potential time zone from START to before POS") - (SETQ TIMEZONE (SUBSTRING *STR* START (SUB1 *POS*))) - (RETURN (SETQ TIMEZONE - (for ZONE in TIME.ZONES bind DST - do (if (STRING-EQUAL TIMEZONE (CADR ZONE)) - then (RETURN (CAR ZONE)) - elseif (AND (SETQ DST (CADDR ZONE)) - (STRING-EQUAL TIMEZONE DST)) - then - (* ; - "The daylight equivalent is off by one hour") + (SETQ TIMEZONE (SUBSTRING *STR* START (SUB1 *POS*))) + (RETURN (SETQ TIMEZONE + (for ZONE in TIME.ZONES bind DST + do (if (STRING-EQUAL TIMEZONE (CADR ZONE)) + then (RETURN (CAR ZONE)) + elseif (AND (SETQ DST (CADDR ZONE)) + (STRING-EQUAL TIMEZONE DST)) + then (* ; + "The daylight equivalent is off by one hour") (RETURN (SUB1 (CAR ZONE] DONE (RETURN (AND (< HOUR 24) @@ -1032,7 +1474,7 @@ DONTCOPY TIMEZONE]) (\IDATESCANTOKEN - [LAMBDA NIL (* ; "Edited 4-May-89 15:20 by bvm") + [LAMBDA NIL (* ; "Edited 4-May-89 15:20 by bvm") (DECLARE (CL:SPECIAL *STR* *POS*)) (* ;; "Returns next token in STR, starting at POS. Is either an integer or list of alphabetic charcodes. Skips blanks") @@ -1048,16 +1490,16 @@ DONTCOPY ((DIGITCHARP CH) (SETQ RESULT (- CH (CHARCODE 0))) [while (AND (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))) - (DIGITCHARP CH)) do (SETQ RESULT (+ (- CH (CHARCODE 0)) - (TIMES RESULT 10] + (DIGITCHARP CH)) do (SETQ RESULT (+ (- CH (CHARCODE 0)) + (TIMES RESULT 10] RESULT) ((ALPHACHARP CH) (CONS (UCASECODE CH) (while (AND (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))) - (ALPHACHARP CH)) collect (UCASECODE CH]) + (ALPHACHARP CH)) collect (UCASECODE CH]) (\IDATE-PARSE-MONTH - [LAMBDA (MONTH) (* ; "Edited 4-May-89 14:54 by bvm") + [LAMBDA (MONTH) (* ; "Edited 4-May-89 14:54 by bvm") (* ;; "MONTH is a list of upper case character codes. Figure out which month (1-12) we mean. We require that MONTH be at least 3 characters long and a prefix of month name") @@ -1068,28 +1510,26 @@ DONTCOPY (* ;; "The entry -- start MINCHARS at 3 and turn the month names into char codes. FORMS is quoted list to workaround masterscope stupidity") - `(DISCRIMINATE-1 3 ,@(FOR F IN (CADR FORMS) - COLLECT (CONS (CHCON (CAR F)) - (CDR F] + `(DISCRIMINATE-1 3 ,@(FOR F IN (CADR FORMS) COLLECT (CONS (CHCON (CAR F)) + (CDR F] [DISCRIMINATE-1 (MINCHARS &BODY FORMS) (IF (NULL (CDR FORMS)) - THEN (* ; "only one case") - `[COND - ((DISCRIMINATE-2 ,MINCHARS ,(CAAR FORMS)) - ,@(CDAR FORMS] - ELSE (* ; - "Discriminate on the first code and recur on the tails") - (LIST* 'CASE `(CAR CODEVAR) - (WHILE FORMS BIND REST C - COLLECT (SETQ REST (CL:REMOVE (SETQ C (CAAAR FORMS)) - FORMS :KEY 'CAAR)) - `(,C (SETQ CODEVAR (CDR CODEVAR)) - (DISCRIMINATE-1 ,(SUB1 MINCHARS) - ,@(FOR F IN (CL:SET-DIFFERENCE FORMS (SETQ FORMS - REST)) - COLLECT (CONS (CDAR F) - (CDR F] + THEN (* ; "only one case") + `[COND + ((DISCRIMINATE-2 ,MINCHARS ,(CAAR FORMS)) + ,@(CDAR FORMS] + ELSE (* ; + "Discriminate on the first code and recur on the tails") + (LIST* 'CASE `(CAR CODEVAR) + (WHILE FORMS BIND REST C + COLLECT (SETQ REST (CL:REMOVE (SETQ C (CAAAR FORMS)) + FORMS :KEY 'CAAR)) + `(,C (SETQ CODEVAR (CDR CODEVAR)) + (DISCRIMINATE-1 ,(SUB1 MINCHARS) + ,@(FOR F IN (CL:SET-DIFFERENCE FORMS (SETQ FORMS REST)) + COLLECT (CONS (CDAR F) + (CDR F] (DISCRIMINATE-2 (MINCHARS MATCHLST) (* ;; "True if codes match MATCHLST, with prefix at least MINCHARS long.") @@ -1097,18 +1537,18 @@ DONTCOPY (IF (NULL MATCHLST) THEN `(NULL CODEVAR) ELSE (LET [(CODE `(AND (EQ (CAR CODEVAR) - ,(POP MATCHLST)) - (PROGN (SETQ CODEVAR (CDR CODEVAR)) - (DISCRIMINATE-2 ,(SUB1 MINCHARS) - ,MATCHLST] - (IF (<= MINCHARS 0) - THEN (* ; "Ok to match null") - `(OR (NULL CODEVAR) - ,CODE) - ELSE (* ; "Must match exactly so far") - CODE] + ,(POP MATCHLST)) + (PROGN (SETQ CODEVAR (CDR CODEVAR)) + (DISCRIMINATE-2 ,(SUB1 MINCHARS) + ,MATCHLST] + (IF (<= MINCHARS 0) + THEN (* ; "Ok to match null") + `(OR (NULL CODEVAR) + ,CODE) + ELSE (* ; "Must match exactly so far") + CODE] (LET ((CODEVAR MONTH)) (* ; - "This LET is solely to allow more compact code (PVAR_ is one byte less than IVARX_)") + "This LET is solely to allow more compact code (PVAR_ is one byte less than IVARX_)") (DISCRIMINATE '(("JANUARY" 1) ("FEBRUARY" 2) ("MARCH" 3) @@ -1123,7 +1563,7 @@ DONTCOPY ("DECEMBER" 12]) (\OUTDATE - [LAMBDA (UD FORMAT STRING) (* ; "Edited 3-May-2018 00:02 by rmk:") + [LAMBDA (UD FORMAT STRING) (* ; "Edited 3-May-2018 00:02 by rmk:") (DESTRUCTURING-BIND (YEAR MONTH DAY HOUR MINUTE SECOND DST WDAY) UD @@ -1136,223 +1576,224 @@ DONTCOPY (if (NOT FORMAT) then NIL elseif (NEQ (CAR (LISTP FORMAT)) - 'DATEFORMAT) + 'DATEFORMAT) then (LISPERROR "ILLEGAL ARG" FORMAT) else (for TOKEN in FORMAT - do (SELECTQ TOKEN - (NO.DATE (SETQ NO.DATE T)) - (NO.TIME (SETQ NO.TIME T)) - (NUMBER.OF.MONTH - (SETQ NUMBER.OF.MONTH T)) - (YEAR.LONG (SETQ YEAR.LONG T)) - (MONTH.LONG (SETQ MONTH.LONG T)) - (MONTH.LEADING (SETQ MONTH.LEADING T)) - (SLASHES (SETQ SEPR (CHARCODE /))) - (SPACES (SETQ SEPR (CHARCODE SPACE))) - (NO.LEADING.SPACES - (SETQ NO.LEADING.SPACES T)) - (TIME.ZONE (SETQ TIME.ZONE - (OR [LISTP (CDR (if (FIXP \TimeZoneComp) - then (ASSOC \TimeZoneComp - TIME.ZONES) - else - (* ; "Ugh, not a small integer") - (CL:ASSOC \TimeZoneComp TIME.ZONES - :TEST '=] - \TimeZoneComp))) - (NO.SECONDS (SETQ NO.SECONDS T)) - (DAY.OF.WEEK (SETQ DAY.OF.WEEK T)) - (DAY.SHORT (SETQ DAY.SHORT T)) - (CIVILIAN.TIME (SETQ CIVILIAN.TIME T)) - NIL))) - (SETQ YEAR.LONG T) (* ; "RMK: Y2K") + do (SELECTQ TOKEN + (NO.DATE (SETQ NO.DATE T)) + (NO.TIME (SETQ NO.TIME T)) + (NUMBER.OF.MONTH + (SETQ NUMBER.OF.MONTH T)) + (YEAR.LONG (SETQ YEAR.LONG T)) + (MONTH.LONG (SETQ MONTH.LONG T)) + (MONTH.LEADING (SETQ MONTH.LEADING T)) + (SLASHES (SETQ SEPR (CHARCODE /))) + (SPACES (SETQ SEPR (CHARCODE SPACE))) + (NO.LEADING.SPACES + (SETQ NO.LEADING.SPACES T)) + (TIME.ZONE (SETQ TIME.ZONE + (OR [LISTP (CDR (if (FIXP \TimeZoneComp) + then (ASSOC \TimeZoneComp TIME.ZONES) + else (* ; "Ugh, not a small integer") + (CL:ASSOC \TimeZoneComp TIME.ZONES :TEST + '=] + \TimeZoneComp))) + (NO.SECONDS (SETQ NO.SECONDS T)) + (DAY.OF.WEEK (SETQ DAY.OF.WEEK T)) + (DAY.SHORT (SETQ DAY.SHORT T)) + (CIVILIAN.TIME (SETQ CIVILIAN.TIME T)) + NIL))) + (SETQ YEAR.LONG T) (* ; "RMK: Y2K") [SETQ SIZE (+ (if NO.DATE then 0 else (+ (if MONTH.LEADING - then (SETQ SEPR (CHARCODE SPACE)) - (SETQ NUMBER.OF.MONTH NIL) (* ; "Will use a comma") - 1 - else 0) - (SETQ MONTH.LENGTH - (if NUMBER.OF.MONTH - then (* ; "Month input is zero-based") - (if (AND (< (add MONTH 1) - 10) - NO.LEADING.SPACES) - then 1 - else 2) - else [SETQ MONTH - (CL:NTH MONTH - '("January" "February" "March" "April" "May" "June" - "July" "August" "September" "October" "November" - "December"] - (if MONTH.LONG - then (NCHARS MONTH) - else 3))) - (SETQ DAY.LENGTH (if (AND (OR NO.LEADING.SPACES MONTH.LEADING) - (< DAY 10)) - then 1 - else 2)) - (SETQ YEAR.LENGTH (if (OR YEAR.LONG (> YEAR 1999)) - then 4 - else (SETQ YEAR (IREMAINDER YEAR 100)) - 2)) - (if DAY.OF.WEEK - then [SETQ DAY.OF.WEEK - (CL:NTH WDAY '("Monday" "Tuesday" "Wednesday" "Thursday" - "Friday" "Saturday" "Sunday"] - [+ 3 (SETQ WDAY.LENGTH (if DAY.SHORT - then - (* ; "3 letters plus %" ()%"") - 3 - else (NCHARS DAY.OF.WEEK] - else 0) - 2)) + then (SETQ SEPR (CHARCODE SPACE)) + (SETQ NUMBER.OF.MONTH NIL) (* ; "Will use a comma") + 1 + else 0) + (SETQ MONTH.LENGTH + (if NUMBER.OF.MONTH + then (* ; "Month input is zero-based") + (if (AND (< (add MONTH 1) + 10) + NO.LEADING.SPACES) + then 1 + else 2) + else [SETQ MONTH + (CL:NTH MONTH + '("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December"] + (if MONTH.LONG + then (NCHARS MONTH) + else 3))) + (SETQ DAY.LENGTH (if (AND (OR NO.LEADING.SPACES MONTH.LEADING) + (< DAY 10)) + then 1 + else 2)) + (SETQ YEAR.LENGTH (if (OR YEAR.LONG (> YEAR 1999)) + then 4 + else (SETQ YEAR (IREMAINDER YEAR 100)) + 2)) + (if DAY.OF.WEEK + then [SETQ DAY.OF.WEEK (CL:NTH WDAY + '("Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday"] + [+ 3 (SETQ WDAY.LENGTH (if DAY.SHORT + then (* ; "3 letters plus %" ()%"") + 3 + else (NCHARS DAY.OF.WEEK] + else 0) + 2)) (if NO.TIME then 0 else (+ (if NO.DATE - then 5 - else 6) - (if NO.SECONDS - then 0 - else 3) - (if CIVILIAN.TIME - then (* ; "Use AM/PM") - (SETQ CIVILIAN.TIME (if (> HOUR 11) - then - (* ; "PM") - (if (> HOUR 12) - then (add HOUR -12)) - (CHARCODE p) - else (if (EQ HOUR 0) - then (SETQ HOUR 12)) - (CHARCODE a))) - (if (AND (< HOUR 10) - NO.LEADING.SPACES) - then (SETQ HOUR.LENGTH 1) - else 2) - else 0) - (if (NULL TIME.ZONE) - then 0 - elseif (NUMBERP TIME.ZONE) - then (* ; "Use the -0800 format") - 6 - else (* ; - "Depends on dst: (normal dst). If missing, we are forced to use numeric format") - (SETQ TIME.ZONE (OR (if DST - then (CADR TIME.ZONE) - else (CAR TIME.ZONE)) - \TimeZoneComp)) - (ADD1 (SETQ TIME.ZONE.LENGTH (NCHARS TIME.ZONE] + then 5 + else 6) + (if NO.SECONDS + then 0 + else 3) + (if CIVILIAN.TIME + then (* ; "Use AM/PM") + (SETQ CIVILIAN.TIME (if (> HOUR 11) + then (* ; "PM") + (if (> HOUR 12) + then (add HOUR -12)) + (CHARCODE p) + else (if (EQ HOUR 0) + then (SETQ HOUR 12)) + (CHARCODE a))) + (if (AND (< HOUR 10) + NO.LEADING.SPACES) + then (SETQ HOUR.LENGTH 1) + else 2) + else 0) + (if (NULL TIME.ZONE) + then 0 + elseif (NUMBERP TIME.ZONE) + then (* ; "Use the -0800 format") + 6 + else (* ; + "Depends on dst: (normal dst). If missing, we are forced to use numeric format") + (SETQ TIME.ZONE (OR (if DST + then (CADR TIME.ZONE) + else (CAR TIME.ZONE)) + \TimeZoneComp)) + (ADD1 (SETQ TIME.ZONE.LENGTH (NCHARS TIME.ZONE] (SETQ S (ALLOCSTRING SIZE (CHARCODE SPACE))) (if (NOT NO.DATE) then (if MONTH.LEADING - then (* ; "Month day, year") - (RPLSTRING S 1 MONTH) - (SETQ N MONTH.LENGTH) - (RPLCHARCODE S (add N 1) - SEPR) - (\RPLRIGHT S (add N (if (< DAY 10) - then 1 - else 2)) - DAY 1) - (RPLCHARCODE S (add N 1) - (CHARCODE ",")) - else (* ; "Daymonthyear") - (\RPLRIGHT S (SETQ N DAY.LENGTH) - DAY 1) - (RPLCHARCODE S (add N 1) - SEPR) - (if NUMBER.OF.MONTH - then (\RPLRIGHT S (add N MONTH.LENGTH) - MONTH MONTH.LENGTH) - else (\OUTDATE-STRING S N MONTH (NOT MONTH.LONG)) - (add N MONTH.LENGTH))) - (RPLCHARCODE S (add N 1) - SEPR) - (\RPLRIGHT S (add N YEAR.LENGTH) - YEAR 2) - (OR NO.TIME (add N 1)) - [if DAY.OF.WEEK - then (* ; - "Day of week at very end in parens") - (LET [(START (SUB1 (- SIZE WDAY.LENGTH] - (RPLCHARCODE S START (CHARCODE "(")) - (\OUTDATE-STRING S START DAY.OF.WEEK DAY.SHORT) - (RPLCHARCODE S SIZE (CHARCODE ")"] + then (* ; "Month day, year") + (RPLSTRING S 1 MONTH) + (SETQ N MONTH.LENGTH) + (RPLCHARCODE S (add N 1) + SEPR) + (\RPLRIGHT S (add N (if (< DAY 10) + then 1 + else 2)) + DAY 1) + (RPLCHARCODE S (add N 1) + (CHARCODE ",")) + else (* ; "Daymonthyear") + (\RPLRIGHT S (SETQ N DAY.LENGTH) + DAY 1) + (RPLCHARCODE S (add N 1) + SEPR) + (if NUMBER.OF.MONTH + then (\RPLRIGHT S (add N MONTH.LENGTH) + MONTH MONTH.LENGTH) + else (\OUTDATE-STRING S N MONTH (NOT MONTH.LONG)) + (add N MONTH.LENGTH))) + (RPLCHARCODE S (add N 1) + SEPR) + (\RPLRIGHT S (add N YEAR.LENGTH) + YEAR 2) + (OR NO.TIME (add N 1)) + [if DAY.OF.WEEK + then (* ; "Day of week at very end in parens") + (LET [(START (SUB1 (- SIZE WDAY.LENGTH] + (RPLCHARCODE S START (CHARCODE "(")) + (\OUTDATE-STRING S START DAY.OF.WEEK DAY.SHORT) + (RPLCHARCODE S SIZE (CHARCODE ")"] else (SETQ N 0)) [if (NOT NO.TIME) then (\RPLRIGHT S (add N HOUR.LENGTH) - HOUR - (if CIVILIAN.TIME - then 1 - else 2)) - (RPLCHARCODE S (ADD1 N) - (CHARCODE %:)) - (\RPLRIGHT S (add N 3) - MINUTE 2) - (if (NOT NO.SECONDS) - then (RPLCHARCODE S (ADD1 N) - (CHARCODE %:)) - (\RPLRIGHT S (add N 3) - SECOND 2)) - (if CIVILIAN.TIME - then (RPLCHARCODE S (ADD1 N) - CIVILIAN.TIME) - (RPLCHARCODE S (add N 2) - (CHARCODE m))) - (if TIME.ZONE - then (if (NUMBERP TIME.ZONE) - then (* ; "+0800 etc") - (if DST - then (* ; - "Daylight savings is in effect, so time zone is off by an hour") - (SETQ TIME.ZONE (SUB1 TIME.ZONE))) - (RPLCHARCODE S (+ N 2) - (if (<= TIME.ZONE 0) - then (* ; - "East of GMT, which is denoted + in this notation") - (SETQ TIME.ZONE (- TIME.ZONE)) - (CHARCODE +) - else (CHARCODE -))) - (if (FIXP TIME.ZONE) - then (* ; "integral number of hours") - (\RPLRIGHT S (+ N 4) - TIME.ZONE 2) - (RPLSTRING S (+ N 5) - "00") - else (CL:MULTIPLE-VALUE-BIND (H M) - (CL:TRUNCATE TIME.ZONE) - (\RPLRIGHT S (+ N 4) - H 2) - (\RPLRIGHT S (+ N 6) - (ROUND (TIMES M 60)) - 2))) - else (RPLSTRING S (+ N 2) - TIME.ZONE] + HOUR + (if CIVILIAN.TIME + then 1 + else 2)) + (RPLCHARCODE S (ADD1 N) + (CHARCODE %:)) + (\RPLRIGHT S (add N 3) + MINUTE 2) + (if (NOT NO.SECONDS) + then (RPLCHARCODE S (ADD1 N) + (CHARCODE %:)) + (\RPLRIGHT S (add N 3) + SECOND 2)) + (if CIVILIAN.TIME + then (RPLCHARCODE S (ADD1 N) + CIVILIAN.TIME) + (RPLCHARCODE S (add N 2) + (CHARCODE m))) + (if TIME.ZONE + then (if (NUMBERP TIME.ZONE) + then (* ; "+0800 etc") + (if DST + then (* ; + "Daylight savings is in effect, so time zone is off by an hour") + (SETQ TIME.ZONE (SUB1 TIME.ZONE))) + (RPLCHARCODE S (+ N 2) + (if (<= TIME.ZONE 0) + then (* ; + "East of GMT, which is denoted + in this notation") + (SETQ TIME.ZONE (- TIME.ZONE)) + (CHARCODE +) + else (CHARCODE -))) + (if (FIXP TIME.ZONE) + then (* ; "integral number of hours") + (\RPLRIGHT S (+ N 4) + TIME.ZONE 2) + (RPLSTRING S (+ N 5) + "00") + else (CL:MULTIPLE-VALUE-BIND (H M) + (CL:TRUNCATE TIME.ZONE) + (\RPLRIGHT S (+ N 4) + H 2) + (\RPLRIGHT S (+ N 6) + (ROUND (TIMES M 60)) + 2))) + else (RPLSTRING S (+ N 2) + TIME.ZONE] (if STRING then (SUBSTRING S 1 -1 STRING) else S]) (\OUTDATE-STRING - [LAMBDA (S N STRING SHORTP) (* ; "Edited 18-May-89 18:38 by bvm") + [LAMBDA (S N STRING SHORTP) (* ; "Edited 18-May-89 18:38 by bvm") (* ;; "Append STRING to S, using only the first 3 chars if SHORTP is true. N is the index of the last char appended to S. Returns new N") (if SHORTP - then (* ; "Use only first 3 chars") - (for I from 1 to 3 do (RPLCHARCODE S (+ N I) - (NTHCHARCODE STRING I))) + then (* ; "Use only first 3 chars") + (for I from 1 to 3 do (RPLCHARCODE S (+ N I) + (NTHCHARCODE STRING I))) else (RPLSTRING S (ADD1 N) - STRING]) + STRING]) (\RPLRIGHT -(LAMBDA (S AT N MINDIGITS) (* bvm%: "21-NOV-83 17:19") (RPLCHARCODE S AT (IPLUS (CHARCODE 0) (IREMAINDER N 10))) (COND ((OR (IGREATERP MINDIGITS 1) (IGEQ N 10)) (\RPLRIGHT S (SUB1 AT) (IQUOTIENT N 10) (SUB1 MINDIGITS))))) -) + [LAMBDA (S AT N MINDIGITS) (* bvm%: "21-NOV-83 17:19") + (RPLCHARCODE S AT (IPLUS (CHARCODE 0) + (IREMAINDER N 10))) + (COND + ((OR (IGREATERP MINDIGITS 1) + (IGEQ N 10)) + (\RPLRIGHT S (SUB1 AT) + (IQUOTIENT N 10) + (SUB1 MINDIGITS]) (\UNPACKDATE - [LAMBDA (D) (* ; "Edited 4-May-89 18:18 by bvm") + [LAMBDA (D) (* ; "Edited 4-May-89 18:18 by bvm") (* ;; "Converts an internal Lisp date D into a list of integers (Year Month Day Hours Minutes Seconds daylightp DayOfWeek). D defaults to current date. --- DayOfWeek is zero for Monday --- --- D is first converted to the alto standard, a 32-bit unsigned integer, representing the number of seconds since jan 1, 1901-Gmt. We have to be a little tricky in our computations to avoid the sign bit.") @@ -1363,7 +1804,7 @@ DONTCOPY 30)) MONTH SEC HR DAY4 YDAY WDAY YEAR4 TOTALDAYS MIN DLS FRAC) (* ; - "DQ is number of minutes since day 0, getting us past the sign bit problem.") + "DQ is number of minutes since day 0, getting us past the sign bit problem.") (SETQ SEC (IMOD [+ D (CONSTANT (- 60 (IMOD MIN.FIXP 60] 60)) (SETQ MIN (IREMAINDER DQ 60)) @@ -1372,73 +1813,70 @@ DONTCOPY [LET ((ZONE \TimeZoneComp)) (if (NOT (FIXP ZONE)) - then (* ; - "Gack, a non-hour offset. Use the integer here, then adjust the minutes, etc.") - (CL:MULTIPLE-VALUE-SETQ (ZONE FRAC) - (CL:FLOOR ZONE))) + then (* ; + "Gack, a non-hour offset. Use the integer here, then adjust the minutes, etc.") + (CL:MULTIPLE-VALUE-SETQ (ZONE FRAC) + (CL:FLOOR ZONE))) (SETQ HR (IREMAINDER (SETQ DQ (- (+ (IQUOTIENT DQ 60) (CONSTANT (ITIMES 24 \4YearsDays))) ZONE)) 24)) (if FRAC - then (SETQ FRAC (ROUND (TIMES FRAC -60))) - (* ; - "Minutes to add (time zones are never below the minute offset)") - (CL:MULTIPLE-VALUE-SETQ (FRAC MIN) - (CL:FLOOR (+ MIN FRAC) - 60)) - (if (NEQ FRAC 0) - then (* ; "Adjust the hours") - (CL:MULTIPLE-VALUE-SETQ (FRAC HR) - (CL:FLOOR (+ HR FRAC) - 24] + then (SETQ FRAC (ROUND (TIMES FRAC -60))) (* ; + "Minutes to add (time zones are never below the minute offset)") + (CL:MULTIPLE-VALUE-SETQ (FRAC MIN) + (CL:FLOOR (+ MIN FRAC) + 60)) + (if (NEQ FRAC 0) + then (* ; "Adjust the hours") + (CL:MULTIPLE-VALUE-SETQ (FRAC HR) + (CL:FLOOR (+ HR FRAC) + 24] (SETQ TOTALDAYS (IQUOTIENT DQ 24)) (if FRAC - then (* ; - "For non-integral time zones, here's the last of the leftover.") - (add TOTALDAYS FRAC)) + then (* ; + "For non-integral time zones, here's the last of the leftover.") + (add TOTALDAYS FRAC)) DTLOOP (SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* ; - "DAY4 = number of days since last leap year day 0") + "DAY4 = number of days since last leap year day 0") [SETQ DAY4 (+ DAY4 (CDR (\DTSCAN DAY4 '((789 . 3) - (424 . 2) - (59 . 1) - (0 . 0](* ; - "pretend every year is a leap year, adding one for days after Feb 28") + (424 . 2) + (59 . 1) + (0 . 0] (* ; + "pretend every year is a leap year, adding one for days after Feb 28") (SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays)) (* ; - "YEAR4 = number of years til that last leap year / 4") + "YEAR4 = number of years til that last leap year / 4") (SETQ YDAY (IREMAINDER DAY4 366)) (* ; - "YDAY is the ordinal day in the year (jan 1 = zero)") + "YDAY is the ordinal day in the year (jan 1 = zero)") (SETQ WDAY (IREMAINDER (+ TOTALDAYS 3) 7)) (if (AND CHECKDLS (SETQ DLS (\ISDST? YDAY HR WDAY))) then + (* ;; "This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year") - (* ;; "This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year") + (if (> (SETQ HR (ADD1 HR)) + 23) + then + (* ;; "overflowed into the next day. This case is too hard (we might have overflowed the month, for example), so just go back and recompute") - (if (> (SETQ HR (ADD1 HR)) - 23) - then - - (* ;; "overflowed into the next day. This case is too hard (we might have overflowed the month, for example), so just go back and recompute") - - (SETQ TOTALDAYS (ADD1 TOTALDAYS)) - (SETQ HR 0) - (SETQ CHECKDLS NIL) - (GO DTLOOP))) + (SETQ TOTALDAYS (ADD1 TOTALDAYS)) + (SETQ HR 0) + (SETQ CHECKDLS NIL) + (GO DTLOOP))) [SETQ MONTH (\DTSCAN YDAY '((335 . 11) - (305 . 10) - (274 . 9) - (244 . 8) - (213 . 7) - (182 . 6) - (152 . 5) - (121 . 4) - (91 . 3) - (60 . 2) - (31 . 1) - (0 . 0] (* ; - "Now return year, month, day, hr, min, sec") + (305 . 10) + (274 . 9) + (244 . 8) + (213 . 7) + (182 . 6) + (152 . 5) + (121 . 4) + (91 . 3) + (60 . 2) + (31 . 1) + (0 . 0] (* ; + "Now return year, month, day, hr, min, sec") (RETURN (LIST (+ 1897 (ITIMES YEAR4 4) (IQUOTIENT DAY4 366)) (CDR MONTH) @@ -1446,9 +1884,9 @@ DONTCOPY HR MIN SEC DLS WDAY]) (\PACKDATE - [LAMBDA (YR MONTH DAY HR MIN SEC TIMEZONE) (* ; "Edited 22-Mar-88 05:33 by jds") - (* ;; - "Packs indicated date into a single integer in Lisp date format. Returns NIL on errors.") + [LAMBDA (YR MONTH DAY HR MIN SEC TIMEZONE) (* ; "Edited 22-Mar-88 05:33 by jds") + + (* ;; "Packs indicated date into a single integer in Lisp date format. Returns NIL on errors.") (PROG (YDAY DAYSSINCEDAY0) (COND @@ -1473,8 +1911,8 @@ DONTCOPY (IQUOTIENT YR 4))) [COND ((> MONTH 1) (* ; "After February 28") - (add YDAY 1) (* ; - "Day-of-year for dst is based on 366-day year") + (add YDAY 1) (* ; + "Day-of-year for dst is based on 366-day year") (COND ((AND (EQ 3 (IREMAINDER YR 4)) (NEQ YR -1)) (* ; "It is a leap year, so real day count also incremented. Note that YR is years since 1901 at this point") @@ -1482,37 +1920,67 @@ DONTCOPY (COND ((OR (< DAYSSINCEDAY0 -1) (< (add HR (TIMES 24 DAYSSINCEDAY0) - (COND - (TIMEZONE) - ((AND \DayLightSavings (\ISDST? YDAY HR (IREMAINDER (+ - DAYSSINCEDAY0 - 1) - 7))) - (* ;; "Subtract one to go from daylight to standard time. This time we computed weekday based on day 0 = Jan 1, 1901, which was a Tuesday = 1") + (COND + (TIMEZONE) + ((AND \DayLightSavings (\ISDST? YDAY HR (IREMAINDER (+ DAYSSINCEDAY0 1) + 7))) - (SUB1 \TimeZoneComp)) - (T \TimeZoneComp))) - 0)) - (* ;; "Earlier than day 0 -- second check is needed because day 0 west of GMT is sometime during Dec 31, 1900") + (* ;; "Subtract one to go from daylight to standard time. This time we computed weekday based on day 0 = Jan 1, 1901, which was a Tuesday = 1") + + (SUB1 \TimeZoneComp)) + (T \TimeZoneComp))) + 0)) + + (* ;; "Earlier than day 0 -- second check is needed because day 0 west of GMT is sometime during Dec 31, 1900") (RETURN))) (RETURN (+ SEC (PROGN - (* ;; "Add the seconds to the converted date, rather than the raw one, and use LLSH instead of multiplying by 60, to avoid creating a bignum") + (* ;; "Add the seconds to the converted date, rather than the raw one, and use LLSH instead of multiplying by 60, to avoid creating a bignum") (ALTO.TO.LISP.DATE (LLSH (TIMES 30 (+ MIN (TIMES 60 HR))) 1]) (\DTSCAN -(LAMBDA (X L) (* lmm%: 22 NOV 75 1438) (PROG NIL LP (COND ((IGREATERP (CAAR L) X) (SETQ L (CDR L)) (GO LP))) (RETURN (CAR L)))) -) + [LAMBDA (X L) (* lmm%: 22 NOV 75 1438) + (PROG NIL + LP (COND + ((IGREATERP (CAAR L) + X) + (SETQ L (CDR L)) + (GO LP))) + (RETURN (CAR L]) (\ISDST? -(LAMBDA (YDAY HOUR WDAY) (* ; "Edited 27-Oct-87 18:51 by bvm:") (* ;; "Returns true if YDAY, HOUR is during the daylight savings period. WDAY is day of week, zero = Monday. YDAY is the ordinal day of the year, pretending it is a leap year, with zero = Jan 1.") (* ;; "Unfortunately, \BeginDST and \EndDST are 1-based and so documented, so we have to convert to zero base inside here.") (AND (\CHECKDSTCHANGE (add YDAY 1) HOUR WDAY \BeginDST) (NOT (\CHECKDSTCHANGE YDAY HOUR WDAY \EndDST)))) -) + [LAMBDA (YDAY HOUR WDAY) (* ; "Edited 27-Oct-87 18:51 by bvm:") + + (* ;; "Returns true if YDAY, HOUR is during the daylight savings period. WDAY is day of week, zero = Monday. YDAY is the ordinal day of the year, pretending it is a leap year, with zero = Jan 1.") + + (* ;; "Unfortunately, \BeginDST and \EndDST are 1-based and so documented, so we have to convert to zero base inside here.") + + (AND (\CHECKDSTCHANGE (add YDAY 1) + HOUR WDAY \BeginDST) + (NOT (\CHECKDSTCHANGE YDAY HOUR WDAY \EndDST]) (\CHECKDSTCHANGE -(LAMBDA (YDAY HOUR WDAY DSTDAY) (* bvm%: " 2-NOV-80 15:34") (* ;; "Tests to see if YDAY, HOUR is after the start of daylight (or standard) time. WDAY is the day of the week, Monday=zero. DSTDAY is the last day of the month in which time changes, as a YDAY, usually Apr 30 or Oct 31") (COND ((IGREATERP YDAY DSTDAY) (* ; "Day is in the next month already") T) ((ILESSP YDAY (IDIFFERENCE DSTDAY 6)) (* ; "day is at least a week before end of month, so time hasn't changed yet") NIL) ((EQ WDAY 6) (* ;; "It's Sunday, so time changes today at 2am. Check for hour being past that. Note that there is a hopeless ambiguity when the time is between 1:00 and 2:00 am the day that DST goes into effect, as that hour happens twice") (IGREATERP HOUR 1)) (T (* ; "okay if last Monday (YDAY-WDAY) is less than a week before end of month") (IGREATERP (IDIFFERENCE YDAY WDAY) (IDIFFERENCE DSTDAY 6))))) -) + [LAMBDA (YDAY HOUR WDAY DSTDAY) (* bvm%: " 2-NOV-80 15:34") + + (* ;; "Tests to see if YDAY, HOUR is after the start of daylight (or standard) time. WDAY is the day of the week, Monday=zero. DSTDAY is the last day of the month in which time changes, as a YDAY, usually Apr 30 or Oct 31") + + (COND + ((IGREATERP YDAY DSTDAY) (* ; "Day is in the next month already") + T) + ((ILESSP YDAY (IDIFFERENCE DSTDAY 6)) (* ; + "day is at least a week before end of month, so time hasn't changed yet") + NIL) + ((EQ WDAY 6) + + (* ;; "It's Sunday, so time changes today at 2am. Check for hour being past that. Note that there is a hopeless ambiguity when the time is between 1:00 and 2:00 am the day that DST goes into effect, as that hour happens twice") + + (IGREATERP HOUR 1)) + (T (* ; + "okay if last Monday (YDAY-WDAY) is less than a week before end of month") + (IGREATERP (IDIFFERENCE YDAY WDAY) + (IDIFFERENCE DSTDAY 6]) ) (DEFOPTIMIZER DATEFORMAT (&REST X) @@ -1566,7 +2034,7 @@ DONTCOPY (LOCALVARS . T) ) -(PUTPROPS IOCHAR FILETYPE CL:COMPILE-FILE) +(PUTPROPS IOCHAR FILETYPE :FAKE-COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DATEFORMAT) @@ -1576,15 +2044,16 @@ DONTCOPY (ADDTOVAR LAMA PACK* CONCAT) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3501 7295 (CHCON 3511 . 4361) (UNPACK 4363 . 5257) (DCHCON 5259 . 6526) (DUNPACK 6528 - . 7293)) (7296 18811 (UALPHORDER 7306 . 7402) (ALPHORDER 7404 . 9207) (CONCAT 9209 . 9854) ( -CONCATCODES 9856 . 10042) (PACKC 10044 . 12647) (PACK 12649 . 13228) (PACK* 13230 . 14952) (\PACK.ITEM - 14954 . 15409) (STRPOS 15411 . 18809)) (18813 19102 (XCL:PACK 18813 . 19102)) (19104 19354 (XCL:PACK* - 19104 . 19354)) (20061 22561 (STRPOSL 20071 . 21697) (MAKEBITTABLE 21699 . 22559)) (22723 23200 ( -CASEARRAY 22733 . 22923) (UPPERCASEARRAY 22925 . 23198)) (23522 57053 (FILEPOS 23532 . 32823) ( -FFILEPOS 32825 . 45096) (\SETUP.FFILEPOS 45098 . 48935) (\SLOWFILEPOS 48937 . 57051)) (57845 99092 ( -DATE 57855 . 57941) (DATEFORMAT 57943 . 58035) (GDATE 58037 . 58148) (IDATE 58150 . 69821) ( -\IDATESCANTOKEN 69823 . 71102) (\IDATE-PARSE-MONTH 71104 . 74800) (\OUTDATE 74802 . 87550) ( -\OUTDATE-STRING 87552 . 88167) (\RPLRIGHT 88169 . 88407) (\UNPACKDATE 88409 . 94200) (\PACKDATE 94202 - . 97522) (\DTSCAN 97524 . 97666) (\ISDST? 97668 . 98175) (\CHECKDSTCHANGE 98177 . 99090))))) + (FILEMAP (NIL (3443 10789 (CHCON 3453 . 4838) (UNPACK 4840 . 6439) (DCHCON 6441 . 8956) (DUNPACK 8958 + . 10787)) (10790 30299 (UALPHORDER 10800 . 10951) (ALPHORDER 10953 . 14398) (CONCAT 14400 . 15424) ( +CONCATCODES 15426 . 15695) (PACKC 15697 . 18346) (PACK 18348 . 19539) (PACK* 19541 . 22841) ( +\PACK.ITEM 22843 . 23570) (STRPOS 23572 . 30297)) (30301 30590 (XCL:PACK 30301 . 30590)) (30592 30842 +(XCL:PACK* 30592 . 30842)) (31549 36610 (STRPOSL 31559 . 35746) (MAKEBITTABLE 35748 . 36608)) (36772 +37540 (CASEARRAY 36782 . 37075) (UPPERCASEARRAY 37077 . 37538)) (37862 71625 (FILEPOS 37872 . 46856) ( +FFILEPOS 46858 . 59668) (\SETUP.FFILEPOS 59670 . 63507) (\SLOWFILEPOS 63509 . 71623)) (72417 112711 ( +DATE 72427 . 72583) (DATEFORMAT 72585 . 72722) (GDATE 72724 . 72897) (IDATE 72899 . 84343) ( +\IDATESCANTOKEN 84345 . 85612) (\IDATE-PARSE-MONTH 85614 . 89168) (\OUTDATE 89170 . 100775) ( +\OUTDATE-STRING 100777 . 101378) (\RPLRIGHT 101380 . 101749) (\UNPACKDATE 101751 . 107433) (\PACKDATE +107435 . 110601) (\DTSCAN 110603 . 110875) (\ISDST? 110877 . 111484) (\CHECKDSTCHANGE 111486 . 112709) +)))) STOP diff --git a/sources/IOCHAR.LCOM b/sources/IOCHAR.LCOM index ec92917b169266ff11f832aa70389aa8c78f4960..c10737ade37989ab23e7a74da9aacc158ff10372 100644 GIT binary patch delta 3714 zcmaJ^U2t1R6_(_L#A>2SvaBSIqpnrQksVvPKa#Gb8pl`il_gu&5t8!bkVO4a21j-h zNCOXrpg8>r4;@N#OWc;BK=_#sg&9jqGDG>f6Sohsc__mKa2Vi$PKO5`km)ePFi>%J zuM{gur<(EI-E(%&o;`c^`;HfXVO+go{Klc9#6J`}@#K)e2?4@$VJ;Bnf^On*KXvBR z=TFX^D3CL!iJN@+(3CQkRHn}lKYiwlXP-Lp^hg4taXI6C%pd3{W;fwmtoXyC5cUV$ ztcn->$EYZ&vg{f>m38yp4 z!2}%04vnEt=#toSQj8ZD<}qI8PwStNz|WOqKKMe;nD;vf*$svSMnRt>O1lNpY)`(L0O#cDZ*Cc$XPqV61{=5w;99G8Xh0UA8{DXTjuXcs1PfjEf?Mz6!cG_{Kp$J^S%6*`U<~vV1v$yk3tz181@CX4;P4DU4BlrU3 z=(v)L$XO+pIGiSeD3IN|VC4{7}~M%Q{RqZXo|I;(q^{yqgXqQg*J7ne*4%2 zevZWEHkhd>wrtR+;P+BY{bSFgB|A8awYSbNEt{jkc8o(8I2IBUv-I%K(H2kcguw!M z*vSVLpbrMw$+5+dS+sG>x4?yacDY>N3zlfD8U#zjvi(XDT)6mI zY)WXj3w#COm|4h%iIgqKDR6H4N4k55mlY5`=N#ZkQ-Qj4g~Wz!*%hh1jA8S7#O-5X932 zH3(x9#`}Hdr2T5SZc|NAi2dYi}x$~jHX5VqKX(7NeJ(P!R{6`! zVnJQ$<41((C|JKanL;-&PNtUL{@KJ_eXY`wSibQ31b)~(Uf)!_n3!0qReqI9-m%BG z(Hqv#O(CR4_spC4kh*oib=mXMuJ3NdHyC+`>MLE5;#~b9HZ`(*q2h?BH$3~h#^>rq zo5`4ne^?!kBnoUVRKH$`s5|=i9(y-}W_e$T9K~dg$+_%wDhgu?qE3il=Evo1oJbF7 z{UJR9JO+bAlNmOR$H#I+$v|W}r(`h~ zyS4Z%bX$^l^r4FmU6wAZJ|uKVEY^52d52lh#cnEgTPR%Eb+PUfwU162Jbo_NJfgqE z@p^bD#O5-@C*hSRQc;Gqbj%ARm5WpQV6hW}7_b(-h_PhhZLAl3(gP@haclw$MH|A0 z)}g1wu!j#)FOqPmiS&FxBva97HU}}tOvyPGcf$MqB%8}nDnQ~Ou|#TYNY~@oM^%bE zmCisKuh>UY)afjd#CseJV8$mC*|h#5eCoo!UAugOKq8Qf6J7`*86D0knUtJtm{wif zk;kk%4Teqf`d!-A9*$L|kH1_p_UhOu3w*T`Z$y2AJ3zCe&KH`Edz_~7_4Dc% zc*jtF?!vlZT@h^++1l(tmJQ&>zh3nw@7mp`74wd~U0ck|=+9^I-Dc;_X6MD~Mxotk zOsEfwJ#_nF(PiHPmU4YlypeAjb?!@|P`YLCNRo6|wT>~stqBtl?@cJbL?LHA!TkP`aF4)8Z-_qFMn;L$0FDo&y-ohdmnrD%v(7_A zKyYJ>L&zA(;u$2k1D!H4m4JHiv?@Cw-2L;SNy(mFz z4`!+_*i2Mp)z&=4=(VOPhdXama=Hj{MZ$xzO!S3#b=bel6cp9Z`nye%U!4u?Y!jtW zqvcS%(}XazGvInCBoX>RFc?9#JK!=08^b_|&e|d%r0IHJkS_1QbiY5#t8WFqZ!`u} z2=dWuk6^No6<%S0C9iC_Wc#PpM(nZcdq)ceaTKc>;|6W?=H_L?+w8ky*!1(+Uyj~1 zt+bJ1ZKhT>`qX!Vy@!_#d56Xr9m^uDKXe#+(lBew?0~+)ipg56{g7=kf2%F;)$Wtw za!v#9sroAPHR^=b{2Wywy1^CKsyo4pxL!8y z1Mc(%!|jH5xAWe4s;G1VH)me^iCj3z-uMr+vT-AgUcO6{PtKWOz>@DS%$aMIeYmgs z^)P4js9IR+_iUkH@Vqv+bsoC$fJN}#$y;$tu(CZY@mh5+I4Ul+6xvbB56;6NSnv`) z`Y*FCAQ;%S)D-pMT08S$re^DKHH(sq5XS0N_vy`!4mp7|Fk?+#nb0c~Y?kuFnmofW z2<*%m8s=f#c9?EU%d5MgR9_5jY4|W)t9Hr_iqT{c&@P7YalIxf*Uxu!DA#*r=t8-S z6^?zCg+*q>=F()!WYz}V_3BbWrNjc(Rh+Gh+*IU7%F~CvbU525bCB!~>q zI+hwtMgh#LKr)Ioq?30kl@Cc+kvk;{q^%Zte74P9 zb>2kIYYG}}U@4=%_UWFHAOaM_4N2ljDy`FHfI~z~O%p%zEjyiG60k%3qNK}_?UFG> k9rfiASM@6+-+5$vI3`ajL-@~B8qsZtLR`N&l}MWZ4=l4yIRF3v delta 4451 zcmb_gU2t1h5x%n1CUH|$k{!o&9Op!J9L0{6`=@)aRO9+ezOrP?T2+$Ux)V@C<*6+x zPA6&0UyJh7QXXI?^p=zj?2Zje^I?V7uEB2f# z*^=7_hQSXy=kD&=vuDrlw|l()s_p9Qwo4BdMR`Pj^05(-7kxw!0KPbNA>Oy%p{^QVf?$6yx)Da!$a4Hl7^l(CW!l!&(?C5;{SRWBJjK<@+4qP zMAIX|IdbMyo&@ly@kt{!k_O`GNE#`aO@@pVIS~#|7_qc293`G`JVj>oX(Jd-r}bbl zW{?vpBR!k&hNpefcO;4dUJD4?|L0D$@*i!#b?(~O z$8qh>H|{WB@4PHOB{@o+y5v}>UT?p!V!Ll#|6rl&K*B3}RvNGVK;O;b-!~Qj$(`8>_ zGxNbi-I%P)#_XA~#HAVVo%nF2fj1 zFhw|`g^p@D0FEXLMwtag7{!Hy5X(Y@Eu310FvQqG9MOU+3s<`!fTsymU=)W@42Ul- zx~{C$oW_elBJ1aY%-nKt9$E1bBbkIGku;$-NF<+1PDEodV^WWK_2eX8zDh!o5X8-& zxZjzRd8Kjbl7I95B~9I=s`BPk-V%^D!$uM?EYnFno=WIRBc4V?BeKt5zI0E*W}7kJ z8~Dxcr-CyZr9UiOT{2%kEJQ{_BzO) z5G;ak(Y2+4V6ITRgQ>AHeeGQ7ZfjXg;_ZMn8XPYe=`JfyQMzhSehTzN5y5O&m z4C}82(F{THGcXM6>C{|21QP}kBtOA4jp(Te(LTmSdFFkA$mXX!z0(4EvSBN(6`Q|g zg*?5ZeUqD>OBnY&O(dylf!Op>E_lwi*#hRDhPwAy&g@`=`LCge?)up{L%v+~1#mgS zW%H@wqqeV^-x>aWCLg)6sT%Y7`|s{}zG5&Ws+QzPv#zyxrmqsoL!Ui% zYdfQ#GWzYkjuwXb(_?#!+f=xzq}z^|Xl-3S5V6c-J4cwMl?b?)HE1vA@nMA1qQeSK zI!Sy!g`5cLq3ICwxer6L?p7Z!W5CBl4M`c}y%L$`s z_{AD8wWgV%U>2le@L;_n62Zq~4Ta>4o(|3x(?%+tjK(L4Ad3X2STpgiWfG@Wr3ls5 zbT}2y8jGe9R!aM&SHbzj&tL#iLyIfKG=Hc zZ+T~1W3c!5XR@hCoUN%mLer0yYVPZWT7G>?o5ffvoZC)HHj|v~E+AG&ao}!D2H3=0 zJKjHdq>{^YWn7i3sRau#u3m3UUaC)4YR{DS@Vjlcl-VsDYPHob^!K%aedVJMBlV1^ zw4QEJ5R2D1kG3sxR6hp6R#2*lqV=FuF_oKRPSH@ZDFzip+2$BkWQy8bLF~gDZTVJ; zi1SSXGAd{eA&G9-+N9xy*72K&m;$U9AR?BB`bIdSZfi!+qy~j0jUtdnc3`@0CdXE8Yzu8w;jIW%F$LXTd=|S39;?pv z@w|ClI?(19&A8OprXj@2``fXaS)-~U8NU@jO7$I+5Ih?lk+4>FD$)U-#$RI&&X+v2d$NE!;{b)yjAnVtAru_)!d{5_jZHSbb{&|e9r z(?s?~26;N7q4OUOC*K*qK0KbKt?QK)o3k?h=B_pFHTHXh+xd(9FUQ|(yU|W^)rIPc zO*bzp1M~GH$aGceeO4cBU;D6q&2(2RZ2c^kcP4wmlfBXA$W_13c0B)fdxo!Uqpfin zu>$<5+B$gZ{oH!Si&Exy)lQO;kq6$5@+4r(Bm&PG793YI$13A6WPaLzcdu1nfzPi~ z^+VXZ3{|ea+PU)4-^_XSiLw3QdH>JWAKQMZSo;gzQ_O9Y_XCebYQ=UO#HDlG&AKT! zGyHkVDD4H&+@~G5^O!x;pDlD$OUF^ascXD#$ULK|#i2bETb`>F?mQ3uXmt*hTNwwc z1_#q+k5tRU&{gWEEoC?ByLy(f_qJL}99J{m^WX(Ly8feo(;LA9=MYQcGj#uJyFn~; zY%Elrod+8|;RP7Q*T*7*Hq+y`7g=98g?(XWtfDV4C<7O>i@I?PEg1bTEEvP~TCdl@ ziViXsWpv;pRzryJ)!AuWAJ(B4={mNTu61UBemhr02dr78AImkV=y@P^2Q#Bu(omp< z@1}gW9USYZVmotyG6%4vZ)Xfr#-JT5vqpQICM442*;edQ{T5Ww;_Eda79y$-DG9@< z7jH$v#1BP`&@|e2cuVRl+$|ew!WG$C(579xD0~*;%^# zu@kQ&fM1d7H0)X$v_|RmZbriggs>Projects>medley>sources>LLSUBRS.;8 27017 - changes to%: (VARS \INITSUBRS) - (FNS WRITECALLSUBRS) +(FILECREATED " 5-Feb-2026 23:25:59" {WMEDLEY}LLSUBRS.;18 26279 - previous date%: "13-Sep-2021 16:07:08" {DSK}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}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 diff --git a/sources/LLSUBRS.LCOM b/sources/LLSUBRS.LCOM index 23c14b2395bf028bbe71b537325ebbdb8801e8c1..060797988039ff24554837076d2524655ea8ebd6 100644 GIT binary patch delta 973 zcmcIj&1(}u6yIG)!PSGcpp~}tF`y)eO|r8e*{o9BY$nOzeuSM(wOB-L3azmpwCY7_ zs7DbL_Tt5ZXD`Jl=&5J#y?FCfya@F_aJC60EmFLAo5!2^z2C>1*DL#-H;t~Gtx=D- z5piNt1q6mtTYRA4A~peQHa2Xdj3A2^)>hV+A1$_FZIxeocFQMKkIZdd-&}jLv9P!~ z<9V!AiCF%cYUMya2BUHqY->6Kxsw6C^D=)oUP-Pb1L#DXz=O^NGSmpE5U4VyD7w@hFSAI8gQ8yK_HA z#!%q+1i{sauo#dN)fwu&8v8PlaYR875>}|p=q9i^7Kc8IBO25}SAhpHC^QpX&u)f{ z#xx8#EI6JQy8SL6WF`m2DapXe@8V?g0#8ezCFNp%0ROc3AK>TJsjdnXnoxw)-2qd| z%T#O*gu9X;i1)ZY;d5bC63(QjQBk;YcxY@H(kHFaX^)CxgUV^I{qW#@`@`$q(tZOAqqLl8IkGDL1zCHxzJABWuK zB#$qPdTN$vB-`2)x2%=9lhRH0@jSJ-^}|t=cr-^*m}THnc@%u}25R~F|+GHkO3A6W0o0i7ynsbvV!`~<;2h@}Q0A_3cR{#J2 delta 1185 zcmcIkOHb5L6mCmmLe=n$kKlxp8qJJxhTcve(`qIRr7(p~XVMmg$O4>cV0cW&DHx3* zY>gWq{RPIQiK4(lH^ik&jT;jeu3Ym2TzKyQaUd+%*u~f0-gD3S&iA$F_tLYK=lPBJ zh-n$RW8^$z7&w$px_&(=@B#v)Xh_ibGzW369IVu<%YFrd8gRfq9(KpqZ%>4NBh21w zROjczY^f0}`sLLyyW&@t{YTj_SZkF1Fl$-v#E|2rZe_&1cgTmu;qoh+Poja zYH&@1_+-v;VaBvgui0b*;v=>TcO26*^xQ$`38**x2i0ILY?8;vTG?L(Bx}5)@mPif zS#i>=S1A2cZtEvqXAKwu9%c%rtJ_I0H-y!)OxH^Q)l1P7Jy^Q1bAB+O@Wm2f=uRq* zBrqJO=pq0 z0dC9n9Mc{J5x=&yQqeU%vuJ}L0&cLV@9$#emFV+8jFE-tD}RMSBDwX5m~T$co3`Oi zmkb;PVie<3CzS1tDtzjHm%fQ&?E;uk0t8c$h59yT+bD`|_P>K_4AoAQ=<1^L9|xO{ z=DNger_H5G7tNSsOcy$Srvl6|gJVDM-sWGWC9riDh8D& RfX9uh3c!-dli2@W{{nI5H>v;t diff --git a/sources/MCCS b/sources/MCCS index cea65763..79e40bbf 100644 --- a/sources/MCCS +++ b/sources/MCCS @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "17-Oct-2025 08:50:00" {WMEDLEY}MCCS.;155 57020 +(FILECREATED " 5-Feb-2026 15:58:32" {WMEDLEY}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}MCCS.;154) + :PREVIOUS-DATE " 5-Feb-2026 12:26:39" {WMEDLEY}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 diff --git a/sources/MCCS.LCOM b/sources/MCCS.LCOM index b46f2b6549dbbcbd2b7cdf2d415c4ff97b9e36f5..71998d1318d39ffcec2dbcdd8cec52342d00b740 100644 GIT binary patch delta 3497 zcmbtXO>7%Q6!toWCfm{`q~a$<=p{h$wu-wmv%B6kNMvKL<89YJwKsnvlmIR*v;xG> z0Rh@82M$Dw1mXw>gaoKGs#GrY#u*_FoVg(`l`78V&6~BGI4(tSi1R%2=6&z?oAKAz zw7-7QK3+Wn_I&N!i}T#%4luiHyJf+*E}ocigaP{8u3b^)yezD(%MTx}~6|sk)d6_$9;mv`*^})k=hizZeHuooYHs_nB$)H?y^+E^?Dy`*a+=dWL z=*AdZ!+_kOTrQVi@OAu`n~)!qxdLOb7PlIeRy6*sRE}hTaS#yumf!n*e`ADS&XOSucK&!l4K)?&6S`NQ%5!YHq@X5eiXN2940Qi z6<6FrmQlk1ZF+w`mtW{nDsOy#eRXp65EbadL@j-?dg#U6^-H%d{zl(l?NPd?rnF19 zUY*L1oj!H*yZY(g0a=6Vr!W5c?ByHN3sbZAMq^h`PWxBj(h;ip51DrF)XgjFeTB2r z;TPZMKCOorW@aX}=f49FK3cMj`ACqKkkJ) z-1tlyv>Uy?MPtv&MrLXv6SC82>ib(S*C&%)fjbtom*cwMtpm4RkWD1}vsev?1Gwc4 z*4n@=KKM4!5VzM*1INE_kGURTL;Ap6YtJ!Ovf#Bo8dlpujvB&d_U*Mccs4dfH|q(< zRhBKRJ~at*VZ(2?gJzW@gLCZX*7V9${(PIP!6G9qF zB*iE5xtz9{ZXZ0J6fEc~SGs7`&~bX@3S}mvRuhOUGdk54Hf5VUkk_t`EllQ!G3{Y1 z{YjIiii-TzVC-h=iDJVhB<)_2NGR z5;J2qAZMj##;4Qg$M2DUkM=I8u^dHqmWO2bP=airDwffmZ~+ZPfNhtRBirDX+F%}R zWLX$+IrhSUy!PY)^)v1p+G1cqQpQEswY`&!T42PbF3U!-85-7}#+xR1O3P6<)M>a? zphw29-%p!(J76RmVY3_iQ8e@x04|`ZeA?vTK`m@nvv-Z`ZV$@%(wTQ9CBMIKZ1+1N zUT+7Fy^o#`IleoK)M_}c5T-xrC$upA_CR}orjlw0jeSy1-#9RXTR-cw={E;rwWJ+9 zmQKw4sSk3tw*C9eF-=?Bo_J*Jo&*Y&R-+4r-q!A%cu01AgQ6MI%7 za(rlFZb;(bTCQ{m^}%xm?Q=|)El7bg6fLrfypAFxe4G)K=^TzenjojS4HykMgTElq z4QZE`5LOv*fm6acPLb_UOu__V(qX|sFv3K35tLRg1Xe)pS|9}36NyAofC5oCc_B(5 zY_;#ACgBMW?T|&hhXf-%yq37y#p{%pC`T5es1PlzGxY|y5JZ?%6nxPMRRFy41UKK6 zQCWzhknxhnZ*t8>6qPl+JUJ)Z_(0?~CDj(_A$eoVSeRiTos8;#T;21FN?j;_1FByM A{Qv*} delta 700 zcmZuu&x_MQ7)`QOF)m`+BIw1>xC^bNWs+vnZZ2*%nc8%dCM4PZSXb~zm)&mH3euy{ zW3R3`DR}WFf|M;Q-ufSS5E1b|5HAJsyiOXdd)PS)-+S+y_szWd^M!r)iG9&XiN&1r zxSx}dgaMUQj8udUyV>g)XMh((<-aNxsiYRr;ppm4?`eOp)7ynk4}|ijWx?sjd_FHg z`(b~leWrtqgbbf9n-uu6aK2wyyiSWBVCUU60gFXVcFa)SkNIQ;#UA1yMy}?9O3%{F8lfVf=RSbz*>_ z>^ZjX7zA99!PQKU7800rM-XW17NIo)TXUfd3TRf~1f&^A(P+vP!48~ebe?u(fO&JC zW7xI!E<@M!)ueH`&PU}iCc^q7W^!=S{XT>H?ZrVPCRyg-WIxGqRrB|UO0|6{A}7`E z*R9cXX)Ss4+{VIjqH=}ZUO2jAv9Z$_TkOTC@1?~KEw(e8a{uT?#kROu2x&3=2V%<& z?%wDllNRMw@JXP7C=X%d7KlaI z)?Am=42k~vssgv6P=bcz86Xv4mYV`i8Xr~1$4fu>(7yF+94x2UaAi3)e!enIgnQYo O8TgicuO@1y#s39hTCXGk diff --git a/sources/MEDLEYDIR b/sources/MEDLEYDIR index ef363133..886f4497 100644 --- a/sources/MEDLEYDIR +++ b/sources/MEDLEYDIR @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "26-Nov-2025 21:51:39" {WMEDLEY}MEDLEYDIR.;43 15970 +(FILECREATED "31-Jan-2026 23:43:06" {WMEDLEY}MEDLEYDIR.;44 16074 :EDIT-BY rmk - :CHANGES-TO (VARS MEDLEYDIRCOMS) + :CHANGES-TO (FNS MEDLEYDIR) - :PREVIOUS-DATE "26-Nov-2025 17:12:16" {WMEDLEY}MEDLEYDIR.;42) + :PREVIOUS-DATE "26-Nov-2025 21:51:39" {WMEDLEY}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 diff --git a/sources/MEDLEYDIR.LCOM b/sources/MEDLEYDIR.LCOM index 8ad061fbf7d7a2d0a3055bd589027d17795b6128..d348dc275b9a382050cec673b8633ccd00c2d637 100644 GIT binary patch delta 273 zcmexw@yB99xQMZ#u2*87u91O}nSznAm5H&Hf!V}tgL)H91ui8cOC(7{D?=k7Qc_4N zN=?qsEy&DCO;Jd#C@3mcwNmhPb@6eHbny&Q$jnnvatrnGQ9#zLr>Cc+kdjye)Pc=Z zBLgK(E)6$NA6MrfSH}=n7X?uzYz~{O%c$UBqF`udU~ZydWwuOxRi`cbp7(nbd3y*Oce|atc)$KjEs~Nl8RE3^K%O_ zb5c_jQY#9IidC%?^72bEGV{_EGV>Ia+(LbP6p*#*>FFscq$HLA)uWkdVP#@uWo)RV z$)(}u>Er4gY|`zGyKhOXG diff --git a/sources/PACKAGE-STARTUP b/sources/PACKAGE-STARTUP index dad817d4..f0af97ce 100644 --- a/sources/PACKAGE-STARTUP +++ b/sources/PACKAGE-STARTUP @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "21-Mar-2024 10:21:14" |{DSK}larry>il>medley>sources>PACKAGE-STARTUP.;9| 36658 +(FILECREATED " 8-Feb-2026 11:47:57" |{WMEDLEY}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}larry>il>medley>sources>PACKAGE-STARTUP.;8| -) + :PREVIOUS-DATE "21-Mar-2024 10:21:14" |{WMEDLEY}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 diff --git a/sources/PACKAGE-STARTUP.LCOM b/sources/PACKAGE-STARTUP.LCOM index 49f479dce9161b37122a31df15a7c1fb634eca5b..145e0e86def43534bb3e843318c9a38f8e9599c1 100644 GIT binary patch delta 550 zcmZ8c%SyvQ6g3q$wI85vybcJhkdRE8hl87GGST29sm)X^xKNvd#YaWl8Sxi{e1IR} z!i`&3?nH1QxOC|^IPrmxyBOx&d(XM&JU%J+Ps-(*0j?Shc2%rn8w`UqU1B&0>Zm_D zJRTklG8i2Jg8XbFVm@cR^QB_4GJRp^4X7fpf4JBr*d>;W0C`E&4mnc;`DBtiJjwwD zUC!Y*LDMuj%XUr&nH>L~lv0aCw^5^7FEzXlqk{Qz>D%knmsy8c((FHTv7LiyJJOsmv@Uf zWvW*FcSEtR=PNhc6=l45*}X0F-gIqyOxE7aM-^B7`lN*+O4fbArc*rh?=G4SY;8rW zR3s7LCYB&(8`^inEE_VYucf`Hm2kkg+%H%DbPW?0d=}6y7b@EntP@inB%O$g1;Dxs s;))Aunbjy344~3~u^rU-(h~ zzqXsz1d8QysRDVz4AYnDM}VR@MnLpk+HNvW@*NPn)HP|{VqQAyucxrGmcGzc14zeZ zUDMh3B!jo$B#RIkwnj>2PV&#ngv#w)xa%)3y{6a4_qp*BKk4~UTvHXWovy)mQ%Y}! zj|MJ5uV=TY@7SPXg+JQtK>iYxOyK)4WbeqXI~L$-=Fcn(YWfj8@8C)WM3Sj~h6TuM g`^>dWufxGRRBzGdFR|gcHuZrV>bh6BeGA`npAl@Li~s-t diff --git a/sources/UFS b/sources/UFS index 29105409..3505edc9 100644 --- a/sources/UFS +++ b/sources/UFS @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "17-Jan-2026 11:06:10" {WMEDLEY}UFS.;62 91935 +(FILECREATED " 6-Feb-2026 23:23:31" {WMEDLEY}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}UFS.;61) + :PREVIOUS-DATE " 5-Feb-2026 18:34:38" {WMEDLEY}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 diff --git a/sources/UFS.LCOM b/sources/UFS.LCOM index 021af392a5666d6b1b63571364adbfbc4c185e89..174a048d70fb001f855b756caaa25b7488bdc7d3 100644 GIT binary patch delta 2866 zcmZuzT}&L;6=oJ=lQrN4FFyecCsQ028rJhaJ8ML;?9Q@N4>QZmEI$c}x$w9LseB#By;H|4lNkbj=B~qm3v1(MMRi!?pFO}T1s+2Z8b9dJU z3|eu|Irq%D-#x$gqc;Ozz8=_~3WG9~E_{7R-~71o zRgti;IyJ7ROnqi;_}bFS@?7ECNN#7lu0IBv5L0=G>nXz<8l8dV7q3D*nMqh=LPb@nVz!}_`ymQ z77Eu3>G_4iP!eJ)jC(dhcRk0j#vmq;x1po-!I?V&dZAV5rx4!&^B5zS?)A-=FZ%rB zAGMnh;UT3@BHWbWxLG|pFaR~Lkr(+3ExJunQvE)lGwj36O4hx$0 zs&{?=^0V(%4Ba_4#Wgbx4>+NjX|&t&)F=((t9#`G+Lns`K~#1-MP-$*C~b!;NGL~9 z+AZZJR9>1IkNXD7|KCx|!Zx~843$OU@^bj&hMLFl>)+fz$8Mugtf@X4r&$q7Pm!IM zy2$6}zcOK6HK`Om=BIO@cSl2j%U3o!%Epx=sw|)0AqAe z1EYCBAgbJbfFj1>0YDLNNC6f_N%K3Sk<>wyM9A0(L=@F3K^vx?^lWDaL`;L~eML^# zXHLMNQF8*GNKFVBn5wS8?LV4VrTaU)+^6m{!%JM*3@_rjWl(+xC8xI98+g23&N8Nf z=TtH=*YUW9z}*X=@sRdgJDPQLGvOJNI9r_xWJM;gCNfNn{5dfckVSH8v^O9~gd1(Q zW5BW?XdJM^xW;74stT}c$SM-BtGHsN(rpR1eKm|YdyWMjvxXhS6>E>KQmpjj(O)yI z&(xl%VO(15bD=Buep!2Km(j^w>J4U+1ohsKl5=Sb{E(%s>k%U9-=3DFgQLWE|KYca zfXEKa8v&DLc1*W)2j2jGUbz(AejV~p{gu27n0Tm1RXqQ_AYyVpB;(X0Wc))iK@%R9 ziKNYpkjAmUx2h0vZO6Nx#RKR;uGE-$udCUAG|(;_RIr|R=mgopTeSrKa_b92`=p%z0ouoL`L7v%&kgbi!P~-ItjeNQ>h}6V( zn4Gy4Ip#wp-`(!0_3`{{yOZ3!1!R3Q+!&e2+35QA TW&%MdHGOaKc0@{bUb!z%@wV)y-jwv(nf_A_~n^Pcnk>;OwaAvVM$I9hPW zrja-as-}IQExm2ENo`p*ZPK(=8@OniS}9-lVVk;Er0qPBjy-U*N8uSh+05` zT;C1}!eUrfiOubovr#7v-b^ALvnSGih@>1NYucG~AdW(Sm-K)=TcTd5)C*CFs4A7g ziIscYzaH6^aTB4+$8BHT?omROT<1xSA!MU#u)6i9u71z16bKNN1Tjqh(7&Jb^lIE3 zv3j5F+tq|Wcfm8b&^*@G-sB6*FyY!%Bx&s)tbEXWm*Z6OR^Pp&e+R=V@ujWMUdsCLt-u5+kP6h(6Lz`$V{ zrqTa+ej#7VCkhMsKny}!-IBEHnAQmhiNsp%t^DV}9nWrRU=7xF3VU^-e!TK~NN(el zivRIKEflXFem{}|36h2dDG&|K+g_z!*Uor+I=HqQOWc;`$4;dvse<7+ zmQ6_o%sBZp#Lpou0#>AJI20FZAqZ~`K?t&jlQwM{8y$?3u3^q6 zJL^&JIM_;FkMx(5>?*6Z*BCjyx&^vD%CMRgMo-kVF@{-Uv46X*y0q_Zp~h7If2J@n z$^L6n7(K!MtqTf0yLt5y%CeN7?cS(sN;2#0JyVBRMV##<^FyOqd(XVx$$F+zKx^|nt_|Hno=C?QBxj;S} z%Jd{VTQ+i2hdOs|d_p zp^4aP$bcNy$fG0O<&X|B+lob9kT*wEEh@66eqn@VQNDjkKz(131PKQWN--ug(IiN+ zu*rz%%Vy}CPk>Hd@`cIw9_>A>;|!|zx{h}?dtDdxYOia8MEalZFJokJAO~q=O)Ft1 zEKtK3eu`Omjp7v3Lf{x_!%e1LWW-HIp~d6a6DfDfwBq&@C^8#WTL4LJI6+;lT`99W zG6uVDudHshS4L0R5S8UneKyIm1YWWuC+lERlo$ULlNgG(Aoq zxdeT3P^M!fqpq1XHs2#{i}mCm9mCBkzIDf<0gs}SuS5sSVhH%yOz}tw^2O&a<(Kfg z1b8pVArW{UB)Saas%wnJRPoEms>ps5SBxOr#=Ni@G%rDIr7K?B$e|~W(PfHjz&7d=qvy{xtX|Gd9M?$W9_!r5{LwAK@=O`M_lN`^m4q1zrOOOK;EO!%qIknqsS|(1hnC-;VKwepn z;NAzze)8|-V@S1+bdu1@0GV2$+_e>%{Cp*d)L&O5(p#318ZZ0FNT!!uFCRkgR=JP- zG227_QuZO&x_XcVR>Mf$JbPd_>ZZEbx3-VmSRF?Ex2pr>!x#EU%NihecnzI7-9yf- zJ&xSKv;E}eS_}E{iv#4BYyF6P{Ng@xZ>^2&Tvw6%Xmu}1t?wg$p6Vnk>%E-!Wq%KO zd%d6hW?jPV|E>#du`%pr)LX3x61jHD1K!H3*NQEvFAa7>TD<>fTE74Jw|D&y)+