diff --git a/internal/loadups/LOADUP-LISP b/internal/loadups/LOADUP-LISP index 61ad45ff7..a84822fe0 100644 --- a/internal/loadups/LOADUP-LISP +++ b/internal/loadups/LOADUP-LISP @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "18-Aug-2025 12:09:49" |{WMEDLEY}loadups>LOADUP-LISP.;21| 6713 +(FILECREATED "16-Oct-2025 16:55:27" |{WMEDLEY}loadups>LOADUP-LISP.;22| 7104 :EDIT-BY |rmk| :CHANGES-TO (FNS LOADUP-LISP) - :PREVIOUS-DATE "15-Jun-2025 14:39:57" |{WMEDLEY}loadups>LOADUP-LISP.;20|) + :PREVIOUS-DATE "18-Aug-2025 12:09:49" |{WMEDLEY}loadups>LOADUP-LISP.;21|) (PRETTYCOMPRINT LOADUP-LISPCOMS) @@ -19,7 +19,8 @@ (DEFINEQ (LOADUP-LISP - (LAMBDA (DRIBBLEFILE) (* \; "Edited 18-Aug-2025 12:08 by rmk") + (LAMBDA (DRIBBLEFILE) (* \; "Edited 16-Oct-2025 16:55 by rmk") + (* \; "Edited 18-Aug-2025 12:08 by rmk") (* \; "Edited 15-Jun-2025 14:39 by rmk") (* \; "Edited 24-May-2025 10:20 by rmk") (* \; "Edited 21-May-2025 09:25 by rmk") @@ -89,9 +90,11 @@ (* |;;| "Before the MEDLEYFONT implementation, FONTPROFILE came after NEWPRINTDEF above, but the loadup failed for undiagnosed reasons. After moving it around, it appears that it must come before MENU, because it creates thw WINDOWTITLEFONT, but after HLDISPLAY. Not yet known what the HLDISPLAY dependency is. ") - (LOADUP '(UNICODE CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU WINDOWOBJ - WINDOWSCROLL WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT - DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)) + (* |;;| "Also, UNICODE is split into UNICODE-TABLES and UNICODE, so the tables are loaded before their MCCS/Uncode client functions are installed. Functions in UFS now depend on those translations so that filenames can have characters outside of Ascii. ") + + (LOADUP '(UNICODE-TABLES UNICODE CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU + WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL + DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)) (LOADUP '(BREAK-AND-TRACE)) (LOADUP '(FASDUMP XCL-COMPILER ADVISE)) @@ -141,5 +144,5 @@ (GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST) ) (DECLARE\: DONTCOPY - (FILEMAP (NIL (640 6507 (LOADUP-LISP 650 . 6505))))) + (FILEMAP (NIL (640 6898 (LOADUP-LISP 650 . 6896))))) STOP diff --git a/internal/loadups/LOADUP-LISP.LCOM b/internal/loadups/LOADUP-LISP.LCOM index edf3b884d..4662329ca 100644 Binary files a/internal/loadups/LOADUP-LISP.LCOM and b/internal/loadups/LOADUP-LISP.LCOM differ diff --git a/library/UNICODE b/library/UNICODE index f091f2894..cf86b5408 100644 --- a/library/UNICODE +++ b/library/UNICODE @@ -1,20 +1,23 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "11-Oct-2025 13:01:09" {WMEDLEY}UNICODE.;179 113928 +(FILECREATED "23-Oct-2025 08:31:21" {WMEDLEY}UNICODE.;211 82245 :EDIT-BY rmk - :CHANGES-TO (VARS UNICODECOMS) - (FNS XCCSTOMCCS-MAPPING READ-UNICODE-MAPPING MAKE-UNICODE-TRANSLATION-TABLES - MERGE-UNICODE-TRANSLATION-TABLES UNICODE-EXTEND-TRANSLATION?) + :CHANGES-TO (FNS UTOMCODE UTF8.INCCODEFN UTOMCODE? UTF8.PEEKCCODEFN) + (VARS UNICODECOMS) + (MACROS UNICODE.SMALLP) - :PREVIOUS-DATE " 5-Oct-2025 17:44:17" {WMEDLEY}UNICODE.;174) + :PREVIOUS-DATE "22-Oct-2025 23:28:51" {WMEDLEY}UNICODE.;210) (PRETTYCOMPRINT UNICODECOMS) (RPAQQ UNICODECOMS - ((COMS (* ; "External formats") + ( + (* ;; "Unicode external formats and MCCS-to-Unicode mapping functions. Must be loaded after UNICODE-TABLES.") + + (COMS (* ; "External formats") (FNS UTF8.OUTCHARFN UTF8.SLUG.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCCODEFN) (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16BE.BACKCCODEFN) @@ -26,38 +29,16 @@ (ADDVARS (*DEFAULT-EXTERNALFORMATS* (UNIX :UTF-8))) (FNS UTF8.BINCODE \UTF8.FETCHCODE) (FNS UTF8.VALIDATE NUTF8-BYTE1-BYTES NUTF8-CODE-BYTES NUTF8-STRING-BYTES N-MCHARS) - (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE \UTF8.GETBASEBYTE)) - (FNS MTOUCODE UTOMCODE MTOUCODE? UTOMCODE? MTOUSTRING UTOMSTRING MTOUTF8STRING - UTF8TOMSTRING) - (FNS XTOUCODE UTOXCODE XTOUCODE? UTOXCODE? XTOUSTRING UTOXSTRING XTOUTF8STRING)) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE \UTF8.GETBASEBYTE + UNICODE.SMALLP))) (* ;; "") - (COMS (* ; "Read Unicode mapping files") - (INITVARS (UNICODEDIRECTORIES NIL)) - (VARS XCCS-CHARSETS) - (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING)) - [COMS (* ; - "Make translation tables for UTF external formats") - (FNS MAKE-UNICODE-TRANSLATION-TABLES XCCSTOMCCS-MAPPING - MERGE-UNICODE-TRANSLATION-TABLES UNICODE.UNMAPPED UNICODE-EXTEND-TRANSLATION?) - (FNS ALL-UNICODE-MAPPINGS XCCSJAPANESECHARSETS) - (INITVARS (*MCCSTOUNICODE*) - (*UNICODETOMCCS*) - (*MCCS-LOADED-CHARSETS*) - (*UNICODE-LOADED-CHARSETS*)) - (GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *NEXT-PRIVATE-UNICODE* - *NEXT-PRIVATE-MCCSCODE* *MCCS-LOADED-CHARSETS* *UNICODE-LOADED-CHARSETS*) - (DECLARE%: EVAL@COMPILE DONTCOPY - - (* ;; "There are 6400 private Unicodes in 25 256-code charsets. For XCCS we map to a contiguous region of unused/reserved--private isn't big enough.") - - (CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000")) - (LAST-PRIVATE-UNICODE (HEXNUM? "F8FF")) - (FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0")) - (LAST-PRIVATE-MCCSCODE (CHARCODE "230,377"))) - (MACROS TRUECODEP)) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES 'ALL] + + (* ;; "These come after the translation tables have been loaded, since the Unix file names needed to read the mapping files depend on the UTF8 string coercions. Those functions are defined as EVQ in UFS, cannot be used until the tables exist. This assumes that previous files have only 7-bit MCCS characters in their names.") + + (FNS MTOUCODE UTOMCODE MTOUCODE? UTOMCODE? MTOUSTRING UTOMSTRING MTOUTF8STRING UTF8TOMSTRING) + (FNS XTOUCODE UTOXCODE XTOUCODE? UTOXCODE? XTOUSTRING UTOXSTRING XTOUTF8STRING) (* ;; "") @@ -77,13 +58,20 @@ (COMS (* ; "debugging") (FNS SHOWCHARS) (DECLARE%: DOEVAL@LOAD DONTCOPY (MACROS HEXCHAR OCTALCHAR))) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (FROM LOADUPS) - EXPORTS.ALL)) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + UNICODE-EXPORTS)) (PROP (FILETYPE) UNICODE))) +(* ;; +"Unicode external formats and MCCS-to-Unicode mapping functions. Must be loaded after UNICODE-TABLES." +) + + + + (* ; "External formats") (DEFINEQ @@ -150,7 +138,8 @@ T]) (UTF8.INCCODEFN - [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 24-Apr-2025 15:44 by rmk") + [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 23-Oct-2025 08:31 by rmk") + (* ; "Edited 24-Apr-2025 15:44 by rmk") (* ; "Edited 2-Feb-2024 11:44 by rmk") (* ; "Edited 30-Jan-2024 22:56 by rmk") (* ; "Edited 6-Aug-2021 16:02 by rmk:") @@ -235,13 +224,15 @@ (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6]) - (CL:UNLESS (OR RAW (NOT (SMALLP CODE))) - (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOMCCS*))) + (CL:UNLESS RAW + (SETQ CODE (UNICODE.TRANSLATE (UNICODE.SMALLP CODE) + *UNICODETOMCCS*))) (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT)) CODE]) (UTF8.PEEKCCODEFN - [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 24-Apr-2025 15:44 by rmk") + [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 23-Oct-2025 08:26 by rmk") + (* ; "Edited 24-Apr-2025 15:44 by rmk") (* ; "Edited 2-Feb-2024 11:48 by rmk") (* ; "Edited 14-Jun-2021 22:53 by rmk:") @@ -324,7 +315,8 @@ elseif NOERROR else (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4] (CL:WHEN (AND CODE (NOT RAW)) - (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOMCCS*))) + (SETQ CODE (UNICODE.TRANSLATE (UNICODE.SMALLP CODE) + *UNICODETOMCCS*))) (RETURN CODE]) (\UTF8.BACKCCODEFN @@ -854,7 +846,7 @@ (* ;; "If RETURNALL and there are alternatives in the RANG, the list is returned. Othewise just the first one if the fake flag allows ") (LET [(RANGE (OR (GETHASH CODE TRANSLATION-TABLE) - (UNICODE.UNMAPPED CODE TRANSLATION-TABLE + (UNICODE.UNMAPPED CODE TRANSLATION-TABLE DONTFAKE] (CL:WHEN RANGE (if (AND RETURNALL (CDR RANGE)) @@ -872,8 +864,26 @@ (ERROR "INVALID UTF8 BYTE" BYTE)) BYTE) ELSE (\GETBASEBYTE BASE OFFSET)))) + +(PUTPROPS UNICODE.SMALLP MACRO [OPENLAMBDA (UNICODE) (* ; + "Cananonicalizes a large UNICODE for EQ hash-testing") + (OR (SMALLP UNICODE) + (CAR (OR (MEMBER UNICODE *LARGEUNICODES*) + (PUSH *LARGEUNICODES* UNICODE]) ) ) + + + +(* ;; "") + + + + +(* ;; +"These come after the translation tables have been loaded, since the Unix file names needed to read the mapping files depend on the UTF8 string coercions. Those functions are defined as EVQ in UFS, cannot be used until the tables exist. This assumes that previous files have only 7-bit MCCS characters in their names." +) + (DEFINEQ (MTOUCODE @@ -883,10 +893,12 @@ (UNICODE.TRANSLATE MCODE *MCCSTOUNICODE*]) (UTOMCODE - [LAMBDA (UNNICODE) (* ; "Edited 24-Apr-2025 10:17 by rmk") + [LAMBDA (UNICODE) (* ; "Edited 23-Oct-2025 08:23 by rmk") + (* ; "Edited 24-Apr-2025 10:17 by rmk") (* ; "Edited 16-Jan-2025 23:46 by rmk") (* ; "Edited 9-Aug-2020 09:04 by rmk:") - (UNICODE.TRANSLATE UNNICODE *UNICODETOMCCS*]) + (UNICODE.TRANSLATE (UNICODE.SMALLP UNICODE) + *UNICODETOMCCS*]) (MTOUCODE? [LAMBDA (MCODE) (* ; "Edited 4-Sep-2025 15:09 by rmk") @@ -902,7 +914,8 @@ (UNICODE.TRANSLATE MCODE *MCCSTOUNICODE* T T]) (UTOMCODE? - [LAMBDA (UNICODE) (* ; "Edited 24-Apr-2025 10:18 by rmk") + [LAMBDA (UNICODE) (* ; "Edited 23-Oct-2025 08:24 by rmk") + (* ; "Edited 24-Apr-2025 10:18 by rmk") (* ; "Edited 19-Jan-2025 21:14 by rmk") (* ; "Edited 18-Jan-2025 11:46 by rmk") (* ; "Edited 15-Jan-2025 19:51 by rmk") @@ -914,7 +927,10 @@ (* ;;  " NOTE: Alternative codes are returned in a list, the code itself is returned for a singleton.") - (UNICODE.TRANSLATE UNICODE *UNICODETOMCCS* T T]) + (* ;; "Canonicalize unicodes outside of the 16-bit plane") + + (UNICODE.TRANSLATE (UNICODE.SMALLP UNICODE) + *UNICODETOMCCS* T T]) (MTOUSTRING [LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 12:19 by rmk") @@ -1002,7 +1018,9 @@ else MSTRING]) (UTF8TOMSTRING - [LAMBDA (UTF8STRING) (* ; "Edited 9-Sep-2025 08:59 by rmk") + [LAMBDA (UTF8STRING) (* ; "Edited 22-Oct-2025 22:00 by rmk") + (* ; "Edited 16-Oct-2025 14:39 by rmk") + (* ; "Edited 9-Sep-2025 08:59 by rmk") (CL:UNLESS (OR (STRINGP UTF8STRING) (LITATOM UTF8STRING)) (SETQ UTF8STRING (MKSTRING UTF8STRING))) @@ -1112,552 +1130,6 @@ -(* ; "Read Unicode mapping files") - - -(RPAQ? UNICODEDIRECTORIES NIL) - -(RPAQQ XCCS-CHARSETS - ((LATIN "0") - (JAPANESE-SYMBOLS1 "41") - (JAPANESE-SYMBOLS2 "42") - (EXTENDED-LATIN "43") - (HIRAGANA "44") - (KATAKANA "45") - (GREEK "46") - (CYRILLIC "47") - (FORMS "50") - (RUNIC-GOTHIC "51") - (MORE-CYRILLIC "52") - (UNKNOWN1 "56") - (UNKNOWN2 "57") - (JIS "60-166") - (ARABIC "340") - (HEBREW "341") - (IPA "342") - (HANGUL "343") - (GEORGIAN-ARMENIAN "344") - (DEVANAGRI "345") - (BENGALI "346") - (GURMUKHI "347") - (THAI-LAO "350") - (SYMBOLS3 "353") - (EXTENDED-ITC-DINGBATS "354") - (ITC-DINGBATS1 "355") - (SYMBOLS2 "356") - (SYMBOLS1 "357") - (LIGATURES "360") - (ACCENTED-LATIN1 "361") - (ACCENTED-LATIN2 "362") - (ACCENTED-GREEK1 "363") - (ACCENTED-GREEK2 "364") - (MORE-ARABIC "365") - (GRAPHIC-VARIANTS "375") - (DEFAULT LATIN ACCENTED-LATIN1 EXTENDED-LATIN SYMBOLS1 SYMBOLS2 FORMS JAPANESE-SYMBOLS1 - JAPANESE-SYMBOLS2) - (JAPANESE HIRAGANA KATAKANA JIS))) -(DEFINEQ - -(READ-UNICODE-MAPPING-FILENAMES - [LAMBDA (FILESPEC) (* ; "Edited 4-Sep-2025 00:11 by rmk") - (* ; "Edited 27-Jan-2025 16:46 by rmk") - (* ; "Edited 21-Jan-2025 22:51 by rmk") - (* ; "Edited 19-Jan-2025 12:21 by rmk") - (* ; "Edited 3-Feb-2024 11:00 by rmk") - (* ; "Edited 30-Jan-2024 08:45 by rmk") - (* ; "Edited 26-Jan-2024 14:02 by mth") - (* ; "Edited 5-Aug-2020 15:59 by kaplan") - (* ; "Edited 4-Aug-2020 17:31 by rmk:") - - (* ;; "FILESPEC can be a file name, character-set name, the name of a collection of character sets, an XCCS character code, or a list of those. Maps those into the names of files that contain the indicated Unicode mappings.") - - (CL:REMOVE-DUPLICATES - [if (EQ FILESPEC 'ALL) - then - (* ;; - "Perhaps should figure out which files in the directories and subdirectories are relevant?") - - (READ-UNICODE-MAPPING-FILENAMES (for N in XCCS-CHARSETS collect (CAR N))) - else (FOR F X CSI INSIDE FILESPEC - JOIN - (* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)") - - (OR (CL:WHEN (CHARCODEP F) (* ; - "An XCCS code can retrieve its character set") - (for D FN (FOCTAL _ (OCTALSTRING (LRSH F 8))) inside UNICODEDIRECTORIES - when (SETQ FN (FILDIR (PACKFILENAME 'DIRECTORY D 'BODY - (CONCAT 'XCCS- FOCTAL '=*) - 'EXTENSION - 'TXT - 'VERSION ""))) do (RETURN FN))) - (MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT 'VERSION "") - T UNICODEDIRECTORIES)) - (for D inside UNICODEDIRECTORIES - when [SETQ $$VAL (OR (FILDIR (PACKFILENAME 'NAME (CONCAT "XCCS-*=" F) - 'EXTENSION - 'TXT - 'VERSION "" 'BODY D)) - (FILDIR (PACKFILENAME 'NAME (CONCAT "XCCS-" F "=*") - 'EXTENSION - 'TXT - 'VERSION "" 'BODY D] - do (RETURN $$VAL)) - (AND (SETQ CSI (ASSOC F XCCS-CHARSETS)) - (READ-UNICODE-MAPPING-FILENAMES (CDR CSI))) - (for D inside UNICODEDIRECTORIES - when (DIRECTORYNAMEP (SETQ D (CONCAT D ">" F ">"))) - join (FILDIR (CONCAT D ">*.TXT;"] - :TEST - (FUNCTION STRING.EQUAL]) - -(READ-UNICODE-MAPPING - [LAMBDA (FILESPEC PRINT NOERROR) (* ; "Edited 11-Oct-2025 12:08 by rmk") - (* ; "Edited 4-Sep-2025 00:17 by rmk") - (* ; "Edited 24-Apr-2025 15:32 by rmk") - (* ; "Edited 31-Jan-2025 17:43 by rmk") - (* ; "Edited 17-Jan-2025 16:41 by rmk") - (* ; "Edited 3-Feb-2024 00:21 by rmk") - (* ; "Edited 5-Jan-2024 12:26 by rmk") - (* ; "Edited 3-Jul-2021 13:37 by rmk:") - - (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and") - - (* ;; " Column 1: XCCS input hex code in the format 0xXXXX") - - (* ;; " Column 2: Corresponding Unicode code-sequence in the format") - - (* ;; " 0xXXXX ... 0xYYYY") - - (* ;; " Column 3: (after #) Character name in some mapping files, utf-8 character") - - (* ;; " for XCCS mapping files") - - (* ;; "") - - (* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode, where fromcode is an XCCS code and the tocodes are corresponding Unicodes.") - - (for FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] in (READ-UNICODE-MAPPING-FILENAMES - FILESPEC) - join - (* ;; "External format :THROUGH means read as bytes, so the Unicode UTF-8 comments cannot cause reading problems.") - - (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT `(:THROUGH LF)) - (bind LINE NAME CHARSET START MAP - first (CL:UNLESS (FILEPOS "Name:" STREAM NIL NIL NIL T) - (ERROR "NOT A UNICODE MAPPING FILE" (FULLNAME STREAM))) - (SETQ NAME (CL:STRING-TRIM " " (CL:READ-LINE STREAM NIL NIL))) - (SETQ CHARSET (CL:IF (FILEPOS "XCCS charset:" STREAM NIL NIL NIL T) - (CL:STRING-TRIM " " (CL:READ-LINE STREAM NIL NIL)) - "")) - (CL:WHEN PRINT (* ; "Strip off XCCS in front of name") - (PRINTOUT T T CHARSET " " [SUBSTRING NAME (CONSTANT - (ADD1 (NCHARS "XCCS"] - T)) while (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) - when (SETQ START (STRPOSL SEPBITTABLE LINE 1 T)) - unless (EQ (CHARCODE %#) - (NTHCHARCODE LINE START)) - collect [SETQ MAP (bind END CODES while [SETQ END (OR (STRPOSL SEPBITTABLE LINE - START) - (ADD1 (NCHARS LINE] - collect [CHARCODE.DECODE (SUBSTRING LINE START - (SUB1 END) - (CONSTANT (CONCAT] - repeatwhile (AND (SETQ START (STRPOSL SEPBITTABLE LINE END - T)) - (NEQ (CHARCODE %#) - (NTHCHARCODE LINE START))) - finally (CL:WHEN (CDDR $$VAL) - (* ; "Combiners go into a CADR list") - (RPLACD $$VAL (CONS (CDR $$VAL))))] - MAP]) -) - - - -(* ; "Make translation tables for UTF external formats") - -(DEFINEQ - -(MAKE-UNICODE-TRANSLATION-TABLES - [LAMBDA (MAPPING REINSTALL) (* ; "Edited 11-Oct-2025 11:54 by rmk") - (* ; "Edited 4-Sep-2025 00:30 by rmk") - (* ; "Edited 24-Apr-2025 15:47 by rmk") - (* ; "Edited 31-Jan-2025 17:46 by rmk") - (* ; "Edited 26-Jan-2025 19:36 by rmk") - (* ; "Edited 22-Jan-2025 14:22 by rmk") - (* ; "Edited 19-Jan-2025 15:08 by rmk") - (* ; "Edited 18-Jan-2025 11:52 by rmk") - (* ; "Edited 3-Feb-2024 00:24 by rmk") - (* ; "Edited 30-Jan-2024 09:54 by rmk") - (* ; "Edited 21-Aug-2021 13:12 by rmk:") - - (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to XCCS-to-Unicode mapping files. This applies the XCCS-to-MCCS translations, and then updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).") - (* ; "Edited 17-Aug-2020 08:46 by rmk:") - (CL:UNLESS [AND (LISTP MAPPING) - (FOR PAIR R IN MAPPING AS I TO 10 - ALWAYS (AND (LISTP PAIR) - (CHARCODEP (CAR PAIR)) - [FIXP (SETQ R (CAR (MKLIST (CADR PAIR] - (CHARCODEP (IABS R] - - (* ;; "Seems like the argument is not already a list of mapping pairs (perhaps with a combiner), presumably a list of charsets to be read.") - - (SETQ MAPPING (READ-UNICODE-MAPPING MAPPING))) - (SETQ MAPPING (XCCSTOMCCS-MAPPING MAPPING)) - - (* ;; "This updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).") - - (* ;; "") - - (* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *XCCSTOUNICODE* and *UNICODETOXCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).") - - (* ;; "") - - (if REINSTALL - then (SETQ *MCCS-LOADED-CHARSETS* (SETQ *UNICODE-LOADED-CHARSETS* NIL)) - (SETQ *NEXT-PRIVATE-MCCSCODE* FIRST-PRIVATE-MCCSCODE) - (SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE) - (LET [(TABLE (HASHARRAY (LENGTH MAPPING))) - (INVERSETABLE (HASHARRAY (LENGTH MAPPING] - (MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING TABLE INVERSETABLE) - (SETQ *MCCSTOUNICODE* TABLE) - (SETQ *UNICODETOMCCS* INVERSETABLE) - (LIST *MCCSTOUNICODE* *UNICODETOMCCS*)) - else (CL:UNLESS (BOUNDP '*NEXT-PRIVATE-MCCSCODE*) - (SETQ *NEXT-PRIVATE-MCCSCODE* FIRST-PRIVATE-MCCSCODE) - (SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE)) - (MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING]) - -(XCCSTOMCCS-MAPPING - [LAMBDA (XTOUMAPPING) (* ; "Edited 11-Oct-2025 12:57 by rmk") - - (* ;; - "This translates the pairs that map XCCS to Unicode into pairs that translate MCCS to Unicode.") - - (* ;; - "We grab the affected pairs before we make any changes so that we don't get into ordering issues.") - - (LET* ([XTOMCODES (CHARCODE ((Currency Dollar) - (Dollar Currency) - (Uparrow Circumflex) - (Circumflex Uparrow) - (Leftarrow Lowline) - (Lowline Leftarrow] - (AFFECTED (for MP in XTOUMAPPING when (thereis XP in XTOMCODES - suchthat (EQ (CAR MP) - (CAR XP))) collect MP))) - (for AP in AFFECTED do (RPLACA AP (CADR (ASSOC (CAR AP) - XTOMCODES))) - finally (push XTOUMAPPING (CHARCODE (DEL DEL))) - (RETURN XTOUMAPPING]) - -(MERGE-UNICODE-TRANSLATION-TABLES - [LAMBDA (INVERSE MAPPING TABLE INVERSETABLE) (* ; "Edited 11-Oct-2025 10:24 by rmk") - (* ; "Edited 24-Apr-2025 15:28 by rmk") - (* ; "Edited 1-Feb-2025 21:42 by rmk") - (* ; "Edited 26-Jan-2025 12:58 by rmk") - (* ; "Edited 22-Jan-2025 08:20 by rmk") - (* ; "Edited 19-Jan-2025 15:58 by rmk") - (* ; "Edited 18-Jan-2025 11:49 by rmk") - (* ; "Edited 27-Mar-2024 12:10 by rmk") - (* ; "Edited 3-Feb-2024 12:46 by rmk") - (* ; "Edited 31-Jan-2024 10:06 by rmk") - - (* ;; "MAPPINGS is a list of pairs that map domain codes to range codes. TABLE and INVERSETABLE default to *MCCSTOUNICODE* *UNICODETOMCCS* respectively. ") - - (CL:UNLESS TABLE - [SETQ TABLE (OR *MCCSTOUNICODE* (SETQ *MCCSTOUNICODE* (HASHARRAY (LENGTH MAPPING]) - (CL:UNLESS INVERSETABLE - [SETQ INVERSETABLE (OR *UNICODETOMCCS* (SETQ *UNICODETOMCCS* (HASHARRAY (LENGTH MAPPING]) - (for M D R OLDR in MAPPING first (CL:IF INVERSE (swap TABLE INVERSETABLE)) - eachtime (SETQ D (CAR M)) - (SETQ R (CADR M)) - - (* ;; "We don't do combiners, but we are allowing non-SMALLP's") - unless (OR (LISTP D) - (LISTP R)) do - (* ;; "The (CONS R OLDR) deals with alternatives: (U X1) (U X2) => (U (X1 X2)), lowest code first. Those are only possible in the U-to-X direction when the tables contain (X1 U) and (X2 U). There are no duplicates/alternative table entries in the X-to-U direction.") - - (SETQ OLDR (GETHASH D TABLE)) - (CL:UNLESS (MEMB R OLDR) - (PUTHASH D (SORT (CONS R OLDR)) - TABLE)) - (swap D R) - (SETQ OLDR (GETHASH D INVERSETABLE)) - (CL:UNLESS (MEMB R OLDR) - (PUTHASH D (SORT (CONS R OLDR)) - INVERSETABLE))) - (LIST TABLE INVERSETABLE]) - -(UNICODE.UNMAPPED - [LAMBDA (CODE TABLE DONTFAKE) (* ; "Edited 24-Apr-2025 15:48 by rmk") - (* ; "Edited 22-Jan-2025 08:19 by rmk") - (* ; "Edited 19-Jan-2025 22:02 by rmk") - (* ; "Edited 18-Jan-2025 12:02 by rmk") - (* ; "Edited 2-Feb-2024 23:52 by rmk") - (* ; "Edited 31-Jan-2024 10:07 by rmk") - (* ; "Edited 11-Aug-2020 20:23 by rmk:") - - (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODE has no fast mapping in TRANSLATION-TABLE.") - - (* ;; "") - - (* ;; "If we have not already installed the mapping segment for that code, we try to retrieve it from the numberic file. If that segment mapping doesn't exist or doesn't have an entry for CODE, we fake up a mapping with a negative range in both directions. One way or the other, there will be an entry for that segment in both mapping vectors.") - - (* ;; "") - - (PROG ((INVERSE (EQ TABLE *UNICODETOMCCS*)) - RANGE HASH) - - (* ;; "If we already looked up CODE's character set in a file, then we have already filled in its information in the translation table. If it didn't have a code for a particular character, then we fake it here. Faked codes are negative, so we can detect them easily, and interpret them with IABS.") - - (CL:WHEN (AND (UNICODE-EXTEND-TRANSLATION? CODE TABLE) - (SETQ RANGE (GETHASH CODE TABLE))) - - (* ;; "We might have gotten the segment that didn't have an entry for CODE.") - - (RETURN RANGE)) - - (* ;; "") - - (CL:UNLESS DONTFAKE - - (* ;; "Our attempt at extending the known tables did not provide a mapping for CODE. So we fake it up with the next unused private code in the code space. ") - - (* ;; "The number of possible faked mappings is determined by the number of private-use Unicodes, since the MCCS character space is pretty sparse. The codes don't have to come from the same part of the code space, and the NEXTCODEs are saved in global variables. The last available codes are constants.") - - (CL:WHEN (IEQP *NEXT-PRIVATE-MCCSCODE* LAST-PRIVATE-MCCSCODE) - (* ; - "Same number of available codes both ways") - (ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES")) - (if INVERSE - then (SETQ RANGE *NEXT-PRIVATE-MCCSCODE*) - (add *NEXT-PRIVATE-MCCSCODE* 1) - else (SETQ RANGE *NEXT-PRIVATE-UNICODE*) - (add *NEXT-PRIVATE-UNICODE* 1)) - (MERGE-UNICODE-TRANSLATION-TABLES INVERSE (CONS (LIST CODE RANGE))) - - (* ;; "CONS because of LIST convention so we can eventually distinguish combiners.") - - (RETURN (CONS RANGE)))]) - -(UNICODE-EXTEND-TRANSLATION? - [LAMBDA (CODE TABLE) (* ; "Edited 11-Oct-2025 09:49 by rmk") - (* ; "Edited 4-Sep-2025 00:34 by rmk") - (* ; "Edited 29-Jun-2025 16:44 by rmk") - (* ; "Edited 24-Apr-2025 15:49 by rmk") - (* ; "Edited 26-Jan-2025 11:26 by rmk") - (* ; "Edited 21-Jan-2025 22:31 by rmk") - (* ; "Edited 18-Jan-2025 12:40 by rmk") - (* ; "Edited 13-Jan-2025 23:50 by rmk") - (* ; "Edited 26-Aug-2024 16:49 by rmk") - (* ; "Edited 27-Mar-2024 23:02 by rmk") - (* ; "Edited 5-Feb-2024 13:48 by rmk") - (* ; "Edited 3-Feb-2024 12:40 by rmk") - - (* ;; "There is currently no mapping for CODE in TABLE, hopefully just because the relevant character-set mapping has not been installed. We infer from TABLE whether CODE is an MCCS or UNICODE code and look for the proper mapping table (forward or inverted) for its character set. ") - - (* ;; "We record which character sets we have already expanded so we don't do them again.") - - (LET ((CHARSET (\CHARSET CODE)) - (INVERSE (EQ TABLE *UNICODETOMCCS*)) - MAPPING FILE) - - (* ;; "If we already looked for CHARSET in the file and found anything, it has already been merged. Otherwise, it would just fail again") - - (CL:UNLESS (MEMB CHARSET (CL:IF INVERSE - *UNICODE-LOADED-CHARSETS* - *MCCS-LOADED-CHARSETS*)) - - (* ;; "Don't try this charset again.") - - (CL:IF INVERSE - (push *UNICODE-LOADED-CHARSETS* CHARSET) - (push *MCCS-LOADED-CHARSETS* CHARSET)) - (SETQ FILE (FINDFILE (CL:IF INVERSE - 'UNICODE-TO-MCCS-MAPPINGS - 'MCCS-TO-UNICODE-MAPPINGS) - T UNICODEDIRECTORIES)) - - (* ;; "The mappings files are indexed by CHARSET.") - - (CL:WHEN [AND FILE (SETQ MAPPING (CL:WITH-OPEN-FILE (STREAM FILE :INPUT) - (CL:WHEN (FILEPOS (CONCAT "[" CHARSET " ") - STREAM NIL NIL NIL T) - (READ STREAM] - - (* ;; - "Merge MAPPING into both tables, respecting the direction indicated by TABLE. ") - - (MERGE-UNICODE-TRANSLATION-TABLES INVERSE MAPPING) - T))]) -) -(DEFINEQ - -(ALL-UNICODE-MAPPINGS - [LAMBDA (INVERTED FILE) (* ; "Edited 24-Apr-2025 15:51 by rmk") - (* ; "Edited 31-Jan-2025 17:46 by rmk") - (* ; "Edited 26-Jan-2025 13:40 by rmk") - (* ; "Edited 22-Jan-2025 14:07 by rmk") - (* ; "Edited 19-Jan-2025 12:20 by rmk") - (* ; "Edited 17-Jan-2025 22:32 by rmk") - (* ; "Edited 15-Jan-2025 09:49 by rmk") - (* ; "Edited 27-Mar-2024 14:48 by rmk") - (* ; "Edited 5-Feb-2024 13:14 by rmk") - (* ; "Edited 3-Feb-2024 09:16 by rmk") - - (* ;; "Reads all the XCCS-to-UNICODE mapping files that we know about, and produces a 2-level index that maps between MCCS codes and UNICODE codes, depending on INVERTED.") - - (* ;; "The first index level segments all the domain codes according to their character sets. The segments are sorted by character set, the pairs within each segment are sorted by their domain codes. ") - - (* ;; - "E.g. if INVERTED=NIL and given a XCCS code, the lookup for the corresponding Unicode(s) is") - - (* ;; " (CADR (ASSOC MCCSCODE (\CHARSET MCCSCODE) INDEX)))).") - - (* ;; "If FILE is not NIL, the result is written to a file. If FILE is T, the file is either MCCS-TO-UNICODE-MAPPINGS.TXT or UNICODE-TO-MCCS-MAPPINGS.TXT, depending on INVERTED.") - - (LET (INDEX) - (for PAIR DOMAIN RANGE CHARSET in (READ-UNICODE-MAPPING 'ALL) eachtime (SETQ DOMAIN - (CAR PAIR)) - (SETQ RANGE (CADR PAIR)) - - (* ;; - "(LISTP RANGE) is a combiner, ignored for now.") - unless (LISTP RANGE) do (CL:WHEN INVERTED (SWAP DOMAIN RANGE)) - - (* ;; - "One segment for each high-byte character set. This aligns with UNICODE-EXTEND.TRANSLATION?") - - [SETQ CHARSET (OR (ASSOC (\CHARSET DOMAIN) - INDEX) - (CAR (push INDEX (CONS (\CHARSET DOMAIN] - - (* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CADR is the first (and almost always) the only one.") - - (pushnew [CDR (OR (ASSOC DOMAIN (CDR CHARSET)) - (CAR (push (CDR CHARSET) - (CONS DOMAIN] - RANGE)) - - (* ;; "Push the charset mappings down an extra CONS, so that a subsequent READ will get them all after a FILEPOS search for super-paren [") - - [for CS in INDEX do (for M in (CDR CS) when (CDDR M) do - (* ;; - "Sort the range alternatives, if any") - - (change (CDR M) - (SORT DATUM))) - - (* ;; "Sort by domain codes and push down a level") - - (change (CDR CS) - (CONS (SORT DATUM T] - (SETQ INDEX (SORT INDEX T)) (* ; "Sort character sets") - (if FILE - then (SETQ FILE (PACKFILENAME 'BODY (if (NEQ FILE T) - then FILE - elseif INVERTED - then 'UNICODE-TO-MCCS-MAPPINGS - else 'MCCS-TO-UNICODE-MAPPINGS) - 'DIRECTORY - (CAR (MKLIST UNICODEDIRECTORIES)) - 'EXTENSION - 'TXT)) - (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) - - (* ;; - "We can FILEPOS for %"[nnn %" then READ for each segment. Or just READFILE to get them all.") - - (for I in INDEX do (PRINTOUT STREAM "[" (CAR I) - " " - (CADR I) - "]" T T)) - (PRINTOUT STREAM "STOP" T) - (FULLNAME STREAM)) - else INDEX]) - -(XCCSJAPANESECHARSETS - [LAMBDA (OCTAL FILE) (* ; "Edited 11-Jun-2025 23:00 by rmk") - - (* ;; "Returns the list of numbers for the Japanese character sets.") - - (for F POS CS in (READ-UNICODE-MAPPING-FILENAMES "JIS") - when (SETQ POS (STRPOS "XCCS-" F 1 NIL NIL T)) - collect [SETQ CS (SUBSTRING F POS (SUB1 (STRPOS '=JIS F POS] - (CL:IF OCTAL - CS - (MKATOM (CONCAT CS "Q"))) - finally (SORT $$VAL) - (CL:WHEN FILE - (RETURN (CL:WITH-OPEN-FILE (STREAM (PACKFILENAME 'BODY (CL:IF (EQ FILE T) - "JAPANESECHARSETS" - FILE) - 'DIRECTORY - (CAR (MKLIST UNICODEDIRECTORIES)) - 'EXTENSION - 'TXT) - :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) - (PRINT $$VAL STREAM) - (FULLNAME STREAM))))]) -) - -(RPAQ? *MCCSTOUNICODE* ) - -(RPAQ? *UNICODETOMCCS* ) - -(RPAQ? *MCCS-LOADED-CHARSETS* ) - -(RPAQ? *UNICODE-LOADED-CHARSETS* ) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *NEXT-PRIVATE-UNICODE* *NEXT-PRIVATE-MCCSCODE* - *MCCS-LOADED-CHARSETS* *UNICODE-LOADED-CHARSETS*) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQ FIRST-PRIVATE-UNICODE (HEXNUM? "E000")) - -(RPAQ LAST-PRIVATE-UNICODE (HEXNUM? "F8FF")) - -(RPAQ FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0")) - -(RPAQ LAST-PRIVATE-MCCSCODE (CHARCODE "230,377")) - - -(CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000")) - (LAST-PRIVATE-UNICODE (HEXNUM? "F8FF")) - (FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0")) - (LAST-PRIVATE-MCCSCODE (CHARCODE "230,377"))) -) - -(DECLARE%: EVAL@COMPILE - -(PUTPROPS TRUECODEP MACRO (OPENLAMBDA (RANGE TABLE) - - (* ;; "Return NIL if RANGE is a fake range in TABLE, otherwise RANGE.") - - (CL:UNLESS (CL:IF (EQ TABLE *MCCSTOUNICODE*) - (AND (IGEQ RANGE FIRST-PRIVATE-UNICODE) - (ILEQ RANGE LAST-PRIVATE-UNICODE)) - (AND (IGEQ RANGE FIRST-PRIVATE-MCCSCODE) - (ILEQ RANGE LAST-PRIVATE-MCCSCODE))) - RANGE))) -) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(MAKE-UNICODE-TRANSLATION-TABLES 'ALL) -) - - - -(* ;; "") - - - - (* ; "Write Unicode mapping files") (DEFINEQ @@ -2005,31 +1477,27 @@ ) (DECLARE%: EVAL@COMPILE DONTCOPY -(FILESLOAD (FROM LOADUPS) - EXPORTS.ALL) +(FILESLOAD (LOADCOMP) + UNICODE-EXPORTS) ) (PUTPROPS UNICODE FILETYPE :TCOMPL) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4573 19821 (UTF8.OUTCHARFN 4583 . 7599) (UTF8.SLUG.OUTCHARFN 7601 . 8265) ( -UTF8.INCCODEFN 8267 . 13988) (UTF8.PEEKCCODEFN 13990 . 18839) (\UTF8.BACKCCODEFN 18841 . 19819)) ( -19822 24512 (UTF16BE.OUTCHARFN 19832 . 20851) (UTF16BE.INCCODEFN 20853 . 21978) (UTF16BE.PEEKCCODEFN -21980 . 23320) (\UTF16BE.BACKCCODEFN 23322 . 24510)) (24513 29236 (UTF16LE.OUTCHARFN 24523 . 25639) ( -UTF16LE.INCCODEFN 25641 . 26766) (UTF16LE.PEEKCCODEFN 26768 . 28044) (\UTF16LE.BACKCCODEFN 28046 . -29234)) (29237 32284 (READBOM 29247 . 31316) (WRITEBOM 31318 . 32282)) (32314 35879 ( -MAKE-UNICODE-FORMATS 32324 . 35877)) (35976 40470 (UTF8.BINCODE 35986 . 38674) (\UTF8.FETCHCODE 38676 - . 40468)) (40471 46098 (UTF8.VALIDATE 40481 . 43078) (NUTF8-BYTE1-BYTES 43080 . 43817) ( -NUTF8-CODE-BYTES 43819 . 44876) (NUTF8-STRING-BYTES 44878 . 45774) (N-MCHARS 45776 . 46096)) (47826 -56695 (MTOUCODE 47836 . 48223) (UTOMCODE 48225 . 48615) (MTOUCODE? 48617 . 49650) (UTOMCODE? 49652 . -50616) (MTOUSTRING 50618 . 51203) (UTOMSTRING 51205 . 51790) (MTOUTF8STRING 51792 . 55798) ( -UTF8TOMSTRING 55800 . 56693)) (56696 62398 (XTOUCODE 56706 . 57224) (UTOXCODE 57226 . 57734) ( -XTOUCODE? 57736 . 58797) (UTOXCODE? 58799 . 59882) (XTOUSTRING 59884 . 60577) (UTOXSTRING 60579 . -61320) (XTOUTF8STRING 61322 . 62396)) (63635 71937 (READ-UNICODE-MAPPING-FILENAMES 63645 . 67442) ( -READ-UNICODE-MAPPING 67444 . 71935)) (72004 86230 (MAKE-UNICODE-TRANSLATION-TABLES 72014 . 75770) ( -XCCSTOMCCS-MAPPING 75772 . 76989) (MERGE-UNICODE-TRANSLATION-TABLES 76991 . 79644) (UNICODE.UNMAPPED -79646 . 82970) (UNICODE-EXTEND-TRANSLATION? 82972 . 86228)) (86231 93067 (ALL-UNICODE-MAPPINGS 86241 - . 91730) (XCCSJAPANESECHARSETS 91732 . 93065)) (94658 105926 (WRITE-UNICODE-MAPPING 94668 . 98418) ( -WRITE-UNICODE-INCLUDED 98420 . 103142) (WRITE-UNICODE-MAPPING-HEADER 103144 . 104392) ( -WRITE-UNICODE-MAPPING-FILENAME 104394 . 105924)) (105927 106603 (XCCS-UTF8-AFTER-OPEN 105937 . 106601) -) (109128 111345 (UTF8HEXSTRING 109138 . 111343)) (111372 113414 (SHOWCHARS 111382 . 113412))))) + (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))))) STOP diff --git a/library/UNICODE-EXPORTS b/library/UNICODE-EXPORTS new file mode 100644 index 000000000..e65ecc222 --- /dev/null +++ b/library/UNICODE-EXPORTS @@ -0,0 +1,79 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "22-Oct-2025 23:27:50" {WMEDLEY}UNICODE-EXPORTS.;1 2673 + + :EDIT-BY rmk + + :CHANGES-TO (VARS UNICODE-EXPORTSCOMS)) + + +(PRETTYCOMPRINT UNICODE-EXPORTSCOMS) + +(RPAQQ UNICODE-EXPORTSCOMS + ( + (* ;; "Compile-time declarations shared by UNICODE-TABLES and UNICODE") + + (GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *NEXT-PRIVATE-UNICODE* *NEXT-PRIVATE-MCCSCODE* + *MCCS-LOADED-CHARSETS* *UNICODE-LOADED-CHARSETS* *LARGEUNICODES*) + + (* ;; "There are 6400 private Unicodes in 25 256-code charsets. For MCCS we map to a contiguous region of unused/reserved--private isn't big enough.") + + (CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000")) + (LAST-PRIVATE-UNICODE (HEXNUM? "F8FF")) + (FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0")) + (LAST-PRIVATE-MCCSCODE (CHARCODE "230,377"))) + (MACROS TRUECODEP) + (FILES (FROM LOADUPS) + EXPORTS.ALL))) + + + +(* ;; "Compile-time declarations shared by UNICODE-TABLES and UNICODE") + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *NEXT-PRIVATE-UNICODE* *NEXT-PRIVATE-MCCSCODE* + *MCCS-LOADED-CHARSETS* *UNICODE-LOADED-CHARSETS* *LARGEUNICODES*) +) + + + +(* ;; +"There are 6400 private Unicodes in 25 256-code charsets. For MCCS we map to a contiguous region of unused/reserved--private isn't big enough." +) + +(DECLARE%: EVAL@COMPILE + +(RPAQ FIRST-PRIVATE-UNICODE (HEXNUM? "E000")) + +(RPAQ LAST-PRIVATE-UNICODE (HEXNUM? "F8FF")) + +(RPAQ FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0")) + +(RPAQ LAST-PRIVATE-MCCSCODE (CHARCODE "230,377")) + + +(CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000")) + (LAST-PRIVATE-UNICODE (HEXNUM? "F8FF")) + (FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0")) + (LAST-PRIVATE-MCCSCODE (CHARCODE "230,377"))) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS TRUECODEP MACRO (OPENLAMBDA (RANGE TABLE) + + (* ;; "Return NIL if RANGE is a fake range in TABLE, otherwise RANGE.") + + (CL:UNLESS (CL:IF (EQ TABLE *MCCSTOUNICODE*) + (AND (IGEQ RANGE FIRST-PRIVATE-UNICODE) + (ILEQ RANGE LAST-PRIVATE-UNICODE)) + (AND (IGEQ RANGE FIRST-PRIVATE-MCCSCODE) + (ILEQ RANGE LAST-PRIVATE-MCCSCODE))) + RANGE))) +) + +(FILESLOAD (FROM LOADUPS) + EXPORTS.ALL) +(DECLARE%: DONTCOPY + (FILEMAP (NIL))) +STOP diff --git a/library/UNICODE-TABLES b/library/UNICODE-TABLES new file mode 100644 index 000000000..71d05c084 --- /dev/null +++ b/library/UNICODE-TABLES @@ -0,0 +1,571 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "22-Oct-2025 23:28:42" {WMEDLEY}UNICODE-TABLES.;4 34028 + + :EDIT-BY rmk + + :CHANGES-TO (VARS UNICODE-TABLESCOMS) + + :PREVIOUS-DATE "16-Oct-2025 16:47:54" {WMEDLEY}UNICODE-TABLES.;3) + + +(PRETTYCOMPRINT UNICODE-TABLESCOMS) + +(RPAQQ UNICODE-TABLESCOMS + [ + (* ;; "Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence.") + + (COMS (* ; "Read Unicode mapping files") + (INITVARS (UNICODEDIRECTORIES NIL)) + (GLOBALVARS UNICODEDIRECTORIES) + (VARS XCCS-CHARSETS) + (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING)) + (COMS (* ; + "Make translation tables for UTF external formats") + (FNS MAKE-UNICODE-TRANSLATION-TABLES XCCSTOMCCS-MAPPING + MERGE-UNICODE-TRANSLATION-TABLES UNICODE.UNMAPPED UNICODE-EXTEND-TRANSLATION?) + (FNS ALL-UNICODE-MAPPINGS XCCSJAPANESECHARSETS) + (INITVARS (*MCCSTOUNICODE*) + (*UNICODETOMCCS*) + (*MCCS-LOADED-CHARSETS*) + (*UNICODE-LOADED-CHARSETS*) + (*LARGEUNICODES*)) + [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES 'ALL] + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + UNICODE-EXPORTS]) + + + +(* ;; +"Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence." +) + + + + +(* ; "Read Unicode mapping files") + + +(RPAQ? UNICODEDIRECTORIES NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS UNICODEDIRECTORIES) +) + +(RPAQQ XCCS-CHARSETS + ((LATIN "0") + (JAPANESE-SYMBOLS1 "41") + (JAPANESE-SYMBOLS2 "42") + (EXTENDED-LATIN "43") + (HIRAGANA "44") + (KATAKANA "45") + (GREEK "46") + (CYRILLIC "47") + (FORMS "50") + (RUNIC-GOTHIC "51") + (MORE-CYRILLIC "52") + (UNKNOWN1 "56") + (UNKNOWN2 "57") + (JIS "60-166") + (ARABIC "340") + (HEBREW "341") + (IPA "342") + (HANGUL "343") + (GEORGIAN-ARMENIAN "344") + (DEVANAGRI "345") + (BENGALI "346") + (GURMUKHI "347") + (THAI-LAO "350") + (SYMBOLS3 "353") + (EXTENDED-ITC-DINGBATS "354") + (ITC-DINGBATS1 "355") + (SYMBOLS2 "356") + (SYMBOLS1 "357") + (LIGATURES "360") + (ACCENTED-LATIN1 "361") + (ACCENTED-LATIN2 "362") + (ACCENTED-GREEK1 "363") + (ACCENTED-GREEK2 "364") + (MORE-ARABIC "365") + (GRAPHIC-VARIANTS "375") + (DEFAULT LATIN ACCENTED-LATIN1 EXTENDED-LATIN SYMBOLS1 SYMBOLS2 FORMS JAPANESE-SYMBOLS1 + JAPANESE-SYMBOLS2) + (JAPANESE HIRAGANA KATAKANA JIS))) +(DEFINEQ + +(READ-UNICODE-MAPPING-FILENAMES + [LAMBDA (FILESPEC) (* ; "Edited 16-Oct-2025 16:43 by rmk") + (* ; "Edited 4-Sep-2025 00:11 by rmk") + (* ; "Edited 27-Jan-2025 16:46 by rmk") + (* ; "Edited 21-Jan-2025 22:51 by rmk") + (* ; "Edited 19-Jan-2025 12:21 by rmk") + (* ; "Edited 3-Feb-2024 11:00 by rmk") + (* ; "Edited 30-Jan-2024 08:45 by rmk") + (* ; "Edited 26-Jan-2024 14:02 by mth") + (* ; "Edited 5-Aug-2020 15:59 by kaplan") + (* ; "Edited 4-Aug-2020 17:31 by rmk:") + + (* ;; "FILESPEC can be a file name, character-set name, the name of a collection of character sets, an XCCS character code, or a list of those. Maps those into the names of files that contain the indicated Unicode mappings.") + + (CL:REMOVE-DUPLICATES [for F X CSI inside (if (EQ FILESPEC 'ALL) + then + (* ;; + "Perhaps should figure out which files in the directories and subdirectories are relevant?") + + (for N in XCCS-CHARSETS + collect (CAR N)) + else FILESPEC) + join + (* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)") + + (OR (CL:WHEN (CHARCODEP F) (* ; + "An XCCS code can retrieve its character set") + (for D FN (FOCTAL _ (OCTALSTRING (LRSH F 8))) inside + UNICODEDIRECTORIES + when (SETQ FN (FILDIR (PACKFILENAME 'DIRECTORY D + 'BODY + (CONCAT 'XCCS- FOCTAL + '=*) + 'EXTENSION + 'TXT + 'VERSION ""))) + do (RETURN FN))) + (MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT + 'VERSION "") + T UNICODEDIRECTORIES)) + (for D inside UNICODEDIRECTORIES + when [SETQ $$VAL (OR (FILDIR (PACKFILENAME 'NAME + (CONCAT "XCCS-*=" F) + 'EXTENSION + 'TXT + 'VERSION "" 'BODY D)) + (FILDIR (PACKFILENAME 'NAME + (CONCAT "XCCS-" F "=*") + 'EXTENSION + 'TXT + 'VERSION "" 'BODY D] + do (RETURN $$VAL)) + (AND (SETQ CSI (ASSOC F XCCS-CHARSETS)) + (READ-UNICODE-MAPPING-FILENAMES (CDR CSI))) + (for D inside UNICODEDIRECTORIES + when (DIRECTORYNAMEP (SETQ D (CONCAT D ">" F ">"))) + join (FILDIR (CONCAT D ">*.TXT;"] + :TEST + (FUNCTION STRING.EQUAL]) + +(READ-UNICODE-MAPPING + [LAMBDA (FILESPEC PRINT NOERROR) (* ; "Edited 16-Oct-2025 11:25 by rmk") + (* ; "Edited 11-Oct-2025 12:08 by rmk") + (* ; "Edited 4-Sep-2025 00:17 by rmk") + (* ; "Edited 24-Apr-2025 15:32 by rmk") + (* ; "Edited 31-Jan-2025 17:43 by rmk") + (* ; "Edited 17-Jan-2025 16:41 by rmk") + (* ; "Edited 3-Feb-2024 00:21 by rmk") + (* ; "Edited 5-Jan-2024 12:26 by rmk") + (* ; "Edited 3-Jul-2021 13:37 by rmk:") + + (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and") + + (* ;; " Column 1: XCCS input hex code in the format 0xXXXX") + + (* ;; " Column 2: Corresponding Unicode code-sequence in the format") + + (* ;; " 0xXXXX ... 0xYYYY") + + (* ;; " Column 3: (after #) Character name in some mapping files, utf-8 character") + + (* ;; " for XCCS mapping files") + + (* ;; "") + + (RESETLST + (for FILE STREAM [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] in ( + READ-UNICODE-MAPPING-FILENAMES + FILESPEC) + join + (* ;; "External format :THROUGH means read as bytes, so the Unicode UTF-8 comments cannot cause reading problems.") + + [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT NIL '((FORMAT :THROUGH) + (EOLCONVENTION LF] + '(PROGN (CLOSEF? OLDVALUE] + (bind LINE NAME CHARSET START + first (CL:UNLESS (FILEPOS "Name:" STREAM NIL NIL NIL T) + (ERROR "NOT A UNICODE MAPPING FILE" (FULLNAME STREAM))) + (SETQ NAME (CL:STRING-TRIM " " (CL:READ-LINE STREAM NIL NIL))) + (SETQ CHARSET (CL:IF (FILEPOS "XCCS charset:" STREAM NIL NIL NIL T) + (CL:STRING-TRIM " " (CL:READ-LINE STREAM NIL NIL)) + "")) + (CL:WHEN PRINT (* ; "Strip off XCCS in front of name") + (PRINTOUT T T CHARSET " " [SUBSTRING NAME (CONSTANT (ADD1 (NCHARS "XCCS" + ] + T)) while (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) + when (SETQ START (STRPOSL SEPBITTABLE LINE 1 T)) + unless (EQ (CHARCODE %#) + (NTHCHARCODE LINE START)) + collect [bind END CODES while [SETQ END (OR (STRPOSL SEPBITTABLE LINE START) + (ADD1 (NCHARS LINE] + collect [CHARCODE.DECODE (SUBSTRING LINE START (SUB1 END) + (CONSTANT (CONCAT] + repeatwhile (AND (SETQ START (STRPOSL SEPBITTABLE LINE END T)) + (NEQ (CHARCODE %#) + (NTHCHARCODE LINE START))) + finally (CL:WHEN (CDDR $$VAL) (* ; "Combiners go into a CADR list") + (RPLACD $$VAL (CONS (CDR $$VAL))))] + finally (CLOSEF? STREAM))))]) +) + + + +(* ; "Make translation tables for UTF external formats") + +(DEFINEQ + +(MAKE-UNICODE-TRANSLATION-TABLES + [LAMBDA (MAPPING REINSTALL) (* ; "Edited 11-Oct-2025 11:54 by rmk") + (* ; "Edited 4-Sep-2025 00:30 by rmk") + (* ; "Edited 24-Apr-2025 15:47 by rmk") + (* ; "Edited 31-Jan-2025 17:46 by rmk") + (* ; "Edited 26-Jan-2025 19:36 by rmk") + (* ; "Edited 22-Jan-2025 14:22 by rmk") + (* ; "Edited 19-Jan-2025 15:08 by rmk") + (* ; "Edited 18-Jan-2025 11:52 by rmk") + (* ; "Edited 3-Feb-2024 00:24 by rmk") + (* ; "Edited 30-Jan-2024 09:54 by rmk") + (* ; "Edited 21-Aug-2021 13:12 by rmk:") + + (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to XCCS-to-Unicode mapping files. This applies the XCCS-to-MCCS translations, and then updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).") + (* ; "Edited 17-Aug-2020 08:46 by rmk:") + (CL:UNLESS [AND (LISTP MAPPING) + (FOR PAIR R IN MAPPING AS I TO 10 + ALWAYS (AND (LISTP PAIR) + (CHARCODEP (CAR PAIR)) + [FIXP (SETQ R (CAR (MKLIST (CADR PAIR] + (CHARCODEP (IABS R] + + (* ;; "Seems like the argument is not already a list of mapping pairs (perhaps with a combiner), presumably a list of charsets to be read.") + + (SETQ MAPPING (READ-UNICODE-MAPPING MAPPING))) + (SETQ MAPPING (XCCSTOMCCS-MAPPING MAPPING)) + + (* ;; "This updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).") + + (* ;; "") + + (* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *XCCSTOUNICODE* and *UNICODETOXCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).") + + (* ;; "") + + (if REINSTALL + then (SETQ *MCCS-LOADED-CHARSETS* (SETQ *UNICODE-LOADED-CHARSETS* NIL)) + (SETQ *NEXT-PRIVATE-MCCSCODE* FIRST-PRIVATE-MCCSCODE) + (SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE) + (LET [(TABLE (HASHARRAY (LENGTH MAPPING))) + (INVERSETABLE (HASHARRAY (LENGTH MAPPING] + (MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING TABLE INVERSETABLE) + (SETQ *MCCSTOUNICODE* TABLE) + (SETQ *UNICODETOMCCS* INVERSETABLE) + (LIST *MCCSTOUNICODE* *UNICODETOMCCS*)) + else (CL:UNLESS (BOUNDP '*NEXT-PRIVATE-MCCSCODE*) + (SETQ *NEXT-PRIVATE-MCCSCODE* FIRST-PRIVATE-MCCSCODE) + (SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE)) + (MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING]) + +(XCCSTOMCCS-MAPPING + [LAMBDA (XTOUMAPPING) (* ; "Edited 11-Oct-2025 12:57 by rmk") + + (* ;; + "This translates the pairs that map XCCS to Unicode into pairs that translate MCCS to Unicode.") + + (* ;; + "We grab the affected pairs before we make any changes so that we don't get into ordering issues.") + + (LET* ([XTOMCODES (CHARCODE ((Currency Dollar) + (Dollar Currency) + (Uparrow Circumflex) + (Circumflex Uparrow) + (Leftarrow Lowline) + (Lowline Leftarrow] + (AFFECTED (for MP in XTOUMAPPING when (thereis XP in XTOMCODES + suchthat (EQ (CAR MP) + (CAR XP))) collect MP))) + (for AP in AFFECTED do (RPLACA AP (CADR (ASSOC (CAR AP) + XTOMCODES))) + finally (push XTOUMAPPING (CHARCODE (DEL DEL))) + (RETURN XTOUMAPPING]) + +(MERGE-UNICODE-TRANSLATION-TABLES + [LAMBDA (INVERSE MAPPING TABLE INVERSETABLE) (* ; "Edited 11-Oct-2025 10:24 by rmk") + (* ; "Edited 24-Apr-2025 15:28 by rmk") + (* ; "Edited 1-Feb-2025 21:42 by rmk") + (* ; "Edited 26-Jan-2025 12:58 by rmk") + (* ; "Edited 22-Jan-2025 08:20 by rmk") + (* ; "Edited 19-Jan-2025 15:58 by rmk") + (* ; "Edited 18-Jan-2025 11:49 by rmk") + (* ; "Edited 27-Mar-2024 12:10 by rmk") + (* ; "Edited 3-Feb-2024 12:46 by rmk") + (* ; "Edited 31-Jan-2024 10:06 by rmk") + + (* ;; "MAPPINGS is a list of pairs that map domain codes to range codes. TABLE and INVERSETABLE default to *MCCSTOUNICODE* *UNICODETOMCCS* respectively. ") + + (CL:UNLESS TABLE + [SETQ TABLE (OR *MCCSTOUNICODE* (SETQ *MCCSTOUNICODE* (HASHARRAY (LENGTH MAPPING]) + (CL:UNLESS INVERSETABLE + [SETQ INVERSETABLE (OR *UNICODETOMCCS* (SETQ *UNICODETOMCCS* (HASHARRAY (LENGTH MAPPING]) + (for M D R OLDR in MAPPING first (CL:IF INVERSE (swap TABLE INVERSETABLE)) + eachtime (SETQ D (CAR M)) + (SETQ R (CADR M)) + + (* ;; "We don't do combiners, but we are allowing non-SMALLP's") + unless (OR (LISTP D) + (LISTP R)) do + (* ;; "The (CONS R OLDR) deals with alternatives: (U X1) (U X2) => (U (X1 X2)), lowest code first. Those are only possible in the U-to-X direction when the tables contain (X1 U) and (X2 U). There are no duplicates/alternative table entries in the X-to-U direction.") + + (SETQ OLDR (GETHASH D TABLE)) + (CL:UNLESS (MEMB R OLDR) + (PUTHASH D (SORT (CONS R OLDR)) + TABLE)) + (swap D R) + (SETQ OLDR (GETHASH D INVERSETABLE)) + (CL:UNLESS (MEMB R OLDR) + (PUTHASH D (SORT (CONS R OLDR)) + INVERSETABLE))) + (LIST TABLE INVERSETABLE]) + +(UNICODE.UNMAPPED + [LAMBDA (CODE TABLE DONTFAKE) (* ; "Edited 24-Apr-2025 15:48 by rmk") + (* ; "Edited 22-Jan-2025 08:19 by rmk") + (* ; "Edited 19-Jan-2025 22:02 by rmk") + (* ; "Edited 18-Jan-2025 12:02 by rmk") + (* ; "Edited 2-Feb-2024 23:52 by rmk") + (* ; "Edited 31-Jan-2024 10:07 by rmk") + (* ; "Edited 11-Aug-2020 20:23 by rmk:") + + (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODE has no fast mapping in TRANSLATION-TABLE.") + + (* ;; "") + + (* ;; "If we have not already installed the mapping segment for that code, we try to retrieve it from the numberic file. If that segment mapping doesn't exist or doesn't have an entry for CODE, we fake up a mapping with a negative range in both directions. One way or the other, there will be an entry for that segment in both mapping vectors.") + + (* ;; "") + + (PROG ((INVERSE (EQ TABLE *UNICODETOMCCS*)) + RANGE HASH) + + (* ;; "If we already looked up CODE's character set in a file, then we have already filled in its information in the translation table. If it didn't have a code for a particular character, then we fake it here. Faked codes are negative, so we can detect them easily, and interpret them with IABS.") + + (CL:WHEN (AND (UNICODE-EXTEND-TRANSLATION? CODE TABLE) + (SETQ RANGE (GETHASH CODE TABLE))) + + (* ;; "We might have gotten the segment that didn't have an entry for CODE.") + + (RETURN RANGE)) + + (* ;; "") + + (CL:UNLESS DONTFAKE + + (* ;; "Our attempt at extending the known tables did not provide a mapping for CODE. So we fake it up with the next unused private code in the code space. ") + + (* ;; "The number of possible faked mappings is determined by the number of private-use Unicodes, since the MCCS character space is pretty sparse. The codes don't have to come from the same part of the code space, and the NEXTCODEs are saved in global variables. The last available codes are constants.") + + (CL:WHEN (IEQP *NEXT-PRIVATE-MCCSCODE* LAST-PRIVATE-MCCSCODE) + (* ; + "Same number of available codes both ways") + (ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES")) + (if INVERSE + then (SETQ RANGE *NEXT-PRIVATE-MCCSCODE*) + (add *NEXT-PRIVATE-MCCSCODE* 1) + else (SETQ RANGE *NEXT-PRIVATE-UNICODE*) + (add *NEXT-PRIVATE-UNICODE* 1)) + (MERGE-UNICODE-TRANSLATION-TABLES INVERSE (CONS (LIST CODE RANGE))) + + (* ;; "CONS because of LIST convention so we can eventually distinguish combiners.") + + (RETURN (CONS RANGE)))]) + +(UNICODE-EXTEND-TRANSLATION? + [LAMBDA (CODE TABLE) (* ; "Edited 11-Oct-2025 09:49 by rmk") + (* ; "Edited 4-Sep-2025 00:34 by rmk") + (* ; "Edited 29-Jun-2025 16:44 by rmk") + (* ; "Edited 24-Apr-2025 15:49 by rmk") + (* ; "Edited 26-Jan-2025 11:26 by rmk") + (* ; "Edited 21-Jan-2025 22:31 by rmk") + (* ; "Edited 18-Jan-2025 12:40 by rmk") + (* ; "Edited 13-Jan-2025 23:50 by rmk") + (* ; "Edited 26-Aug-2024 16:49 by rmk") + (* ; "Edited 27-Mar-2024 23:02 by rmk") + (* ; "Edited 5-Feb-2024 13:48 by rmk") + (* ; "Edited 3-Feb-2024 12:40 by rmk") + + (* ;; "There is currently no mapping for CODE in TABLE, hopefully just because the relevant character-set mapping has not been installed. We infer from TABLE whether CODE is an MCCS or UNICODE code and look for the proper mapping table (forward or inverted) for its character set. ") + + (* ;; "We record which character sets we have already expanded so we don't do them again.") + + (LET ((CHARSET (\CHARSET CODE)) + (INVERSE (EQ TABLE *UNICODETOMCCS*)) + MAPPING FILE) + + (* ;; "If we already looked for CHARSET in the file and found anything, it has already been merged. Otherwise, it would just fail again") + + (CL:UNLESS (MEMB CHARSET (CL:IF INVERSE + *UNICODE-LOADED-CHARSETS* + *MCCS-LOADED-CHARSETS*)) + + (* ;; "Don't try this charset again.") + + (CL:IF INVERSE + (push *UNICODE-LOADED-CHARSETS* CHARSET) + (push *MCCS-LOADED-CHARSETS* CHARSET)) + (SETQ FILE (FINDFILE (CL:IF INVERSE + 'UNICODE-TO-MCCS-MAPPINGS + 'MCCS-TO-UNICODE-MAPPINGS) + T UNICODEDIRECTORIES)) + + (* ;; "The mappings files are indexed by CHARSET.") + + (CL:WHEN [AND FILE (SETQ MAPPING (CL:WITH-OPEN-FILE (STREAM FILE :INPUT) + (CL:WHEN (FILEPOS (CONCAT "[" CHARSET " ") + STREAM NIL NIL NIL T) + (READ STREAM] + + (* ;; + "Merge MAPPING into both tables, respecting the direction indicated by TABLE. ") + + (MERGE-UNICODE-TRANSLATION-TABLES INVERSE MAPPING) + T))]) +) +(DEFINEQ + +(ALL-UNICODE-MAPPINGS + [LAMBDA (INVERTED FILE) (* ; "Edited 24-Apr-2025 15:51 by rmk") + (* ; "Edited 31-Jan-2025 17:46 by rmk") + (* ; "Edited 26-Jan-2025 13:40 by rmk") + (* ; "Edited 22-Jan-2025 14:07 by rmk") + (* ; "Edited 19-Jan-2025 12:20 by rmk") + (* ; "Edited 17-Jan-2025 22:32 by rmk") + (* ; "Edited 15-Jan-2025 09:49 by rmk") + (* ; "Edited 27-Mar-2024 14:48 by rmk") + (* ; "Edited 5-Feb-2024 13:14 by rmk") + (* ; "Edited 3-Feb-2024 09:16 by rmk") + + (* ;; "Reads all the XCCS-to-UNICODE mapping files that we know about, and produces a 2-level index that maps between MCCS codes and UNICODE codes, depending on INVERTED.") + + (* ;; "The first index level segments all the domain codes according to their character sets. The segments are sorted by character set, the pairs within each segment are sorted by their domain codes. ") + + (* ;; + "E.g. if INVERTED=NIL and given a XCCS code, the lookup for the corresponding Unicode(s) is") + + (* ;; " (CADR (ASSOC MCCSCODE (\CHARSET MCCSCODE) INDEX)))).") + + (* ;; "If FILE is not NIL, the result is written to a file. If FILE is T, the file is either MCCS-TO-UNICODE-MAPPINGS.TXT or UNICODE-TO-MCCS-MAPPINGS.TXT, depending on INVERTED.") + + (LET (INDEX) + (for PAIR DOMAIN RANGE CHARSET in (READ-UNICODE-MAPPING 'ALL) eachtime (SETQ DOMAIN + (CAR PAIR)) + (SETQ RANGE (CADR PAIR)) + + (* ;; + "(LISTP RANGE) is a combiner, ignored for now.") + unless (LISTP RANGE) do (CL:WHEN INVERTED (SWAP DOMAIN RANGE)) + + (* ;; + "One segment for each high-byte character set. This aligns with UNICODE-EXTEND.TRANSLATION?") + + [SETQ CHARSET (OR (ASSOC (\CHARSET DOMAIN) + INDEX) + (CAR (push INDEX (CONS (\CHARSET DOMAIN] + + (* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CADR is the first (and almost always) the only one.") + + (pushnew [CDR (OR (ASSOC DOMAIN (CDR CHARSET)) + (CAR (push (CDR CHARSET) + (CONS DOMAIN] + RANGE)) + + (* ;; "Push the charset mappings down an extra CONS, so that a subsequent READ will get them all after a FILEPOS search for super-paren [") + + [for CS in INDEX do (for M in (CDR CS) when (CDDR M) do + (* ;; + "Sort the range alternatives, if any") + + (change (CDR M) + (SORT DATUM))) + + (* ;; "Sort by domain codes and push down a level") + + (change (CDR CS) + (CONS (SORT DATUM T] + (SETQ INDEX (SORT INDEX T)) (* ; "Sort character sets") + (if FILE + then (SETQ FILE (PACKFILENAME 'BODY (if (NEQ FILE T) + then FILE + elseif INVERTED + then 'UNICODE-TO-MCCS-MAPPINGS + else 'MCCS-TO-UNICODE-MAPPINGS) + 'DIRECTORY + (CAR (MKLIST UNICODEDIRECTORIES)) + 'EXTENSION + 'TXT)) + (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) + + (* ;; + "We can FILEPOS for %"[nnn %" then READ for each segment. Or just READFILE to get them all.") + + (for I in INDEX do (PRINTOUT STREAM "[" (CAR I) + " " + (CADR I) + "]" T T)) + (PRINTOUT STREAM "STOP" T) + (FULLNAME STREAM)) + else INDEX]) + +(XCCSJAPANESECHARSETS + [LAMBDA (OCTAL FILE) (* ; "Edited 11-Jun-2025 23:00 by rmk") + + (* ;; "Returns the list of numbers for the Japanese character sets.") + + (for F POS CS in (READ-UNICODE-MAPPING-FILENAMES "JIS") + when (SETQ POS (STRPOS "XCCS-" F 1 NIL NIL T)) + collect [SETQ CS (SUBSTRING F POS (SUB1 (STRPOS '=JIS F POS] + (CL:IF OCTAL + CS + (MKATOM (CONCAT CS "Q"))) + finally (SORT $$VAL) + (CL:WHEN FILE + (RETURN (CL:WITH-OPEN-FILE (STREAM (PACKFILENAME 'BODY (CL:IF (EQ FILE T) + "JAPANESECHARSETS" + FILE) + 'DIRECTORY + (CAR (MKLIST UNICODEDIRECTORIES)) + 'EXTENSION + 'TXT) + :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) + (PRINT $$VAL STREAM) + (FULLNAME STREAM))))]) +) + +(RPAQ? *MCCSTOUNICODE* ) + +(RPAQ? *UNICODETOMCCS* ) + +(RPAQ? *MCCS-LOADED-CHARSETS* ) + +(RPAQ? *UNICODE-LOADED-CHARSETS* ) + +(RPAQ? *LARGEUNICODES* ) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(MAKE-UNICODE-TRANSLATION-TABLES 'ALL) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) + UNICODE-EXPORTS) +) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (3341 12542 (READ-UNICODE-MAPPING-FILENAMES 3351 . 8301) (READ-UNICODE-MAPPING 8303 . +12540)) (12609 26839 (MAKE-UNICODE-TRANSLATION-TABLES 12619 . 16379) (XCCSTOMCCS-MAPPING 16381 . 17598 +) (MERGE-UNICODE-TRANSLATION-TABLES 17600 . 20253) (UNICODE.UNMAPPED 20255 . 23579) ( +UNICODE-EXTEND-TRANSLATION? 23581 . 26837)) (26840 33676 (ALL-UNICODE-MAPPINGS 26850 . 32339) ( +XCCSJAPANESECHARSETS 32341 . 33674))))) +STOP diff --git a/library/UNICODE-TABLES.LCOM b/library/UNICODE-TABLES.LCOM new file mode 100644 index 000000000..d339e0387 Binary files /dev/null and b/library/UNICODE-TABLES.LCOM differ diff --git a/library/UNICODE.LCOM b/library/UNICODE.LCOM index 32d12b9ed..b14e049ab 100644 Binary files a/library/UNICODE.LCOM and b/library/UNICODE.LCOM differ diff --git a/library/tedit/TEDIT-FILE b/library/tedit/TEDIT-FILE index 7ac1a3fef..b529ddc8e 100644 --- a/library/tedit/TEDIT-FILE +++ b/library/tedit/TEDIT-FILE @@ -1,14 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Sep-2025 21:32:46"  -{DSK}kaplan>Local>medley3.5>working-medley>library>tedit>TEDIT-FILE.;655 173148 +(FILECREATED "23-Oct-2025 08:49:06" {WMEDLEY}tedit>TEDIT-FILE.;656 173140 :EDIT-BY rmk - :CHANGES-TO (FNS \TEDIT.GET.FORMATTED.FILE \TEDIT.PUT.SINGLE.CHARLOOKS - \TEDIT.GET.SINGLE.CHARLOOKS) + :CHANGES-TO (FNS \TEDIT.GET.UNFORMATTED.FILE.UTF8) - :PREVIOUS-DATE " 9-Sep-2025 21:49:43" {WMEDLEY}tedit>TEDIT-FILE.;653) + :PREVIOUS-DATE "25-Sep-2025 21:32:46" {WMEDLEY}tedit>TEDIT-FILE.;655) (PRETTYCOMPRINT TEDIT-FILECOMS) @@ -1388,7 +1386,8 @@ (DEFINEQ (\TEDIT.GET.UNFORMATTED.FILE.UTF8 - [LAMBDA (STRM START END DEFAULTCHARLOOKS DEFAULTPARALOOKS) (* ; "Edited 28-Jul-2025 23:45 by rmk") + [LAMBDA (STRM START END DEFAULTCHARLOOKS DEFAULTPARALOOKS) (* ; "Edited 23-Oct-2025 08:48 by rmk") + (* ; "Edited 28-Jul-2025 23:45 by rmk") (* ; "Edited 11-Mar-2024 23:55 by rmk") (* ; "Edited 4-Feb-2024 10:12 by rmk") (* ; "Edited 2-Feb-2024 11:24 by rmk") @@ -1428,7 +1427,7 @@ (SETQ CHAR (\PEEKBIN STRM)) (* ;  "Keep CHAR for CR/LF checking, error if EOF") (* ; "Error if invalid header") - (SETQ NEXTCODESIZE (UTF8-SIZE-FROM-BYTE1 CHAR)) + (SETQ NEXTCODESIZE (NUTF8-BYTE1-BYTES CHAR)) (CL:UNLESS (EQ CODESIZE NEXTCODESIZE) (* ; "Header byte hasn't been read") (* ;; "Don't want LF processing if we split because of size change. If next is a CR/LF still in size 1, we pick it up below") @@ -2694,28 +2693,28 @@ (RPAQ? *TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (5431 35690 (TEDIT.GET 5441 . 11851) (TEDIT.FORMATTEDFILEP 11853 . 13169) ( -TEDIT.FILEDATE 13171 . 14480) (TEDIT.INCLUDE 14482 . 22511) (TEDIT.RAW.INCLUDE 22513 . 23321) ( -TEDIT.PUT 23323 . 31679) (TEDIT.PUT.STREAM 31681 . 35688)) (35691 56965 (\TEDIT.GET.FOREIGN.FILE 35701 - . 39126) (\TEDIT.GET.UNFORMATTED.FILE 39128 . 43434) (\TEDIT.GET.FORMATTED.FILE 43436 . 47079) ( -\TEDIT.FORMATTEDSTREAMP 47081 . 50212) (\ARBIN 50214 . 50934) (\ATMIN 50936 . 51473) (\DWIN 51475 . -51854) (\STRINGIN 51856 . 52564) (\TEDIT.GET.TRAILER 52566 . 55434) (\TEDIT.CACHEFILE 55436 . 56963)) -(57131 73169 (\TEDIT.GET.PIECES3 57141 . 68104) (\TEDIT.GET.PROPS3 68106 . 71328) ( -\TEDIT.MAKE.STRINGPIECE 71330 . 73167)) (73170 86596 (\TEDIT.GET.UNFORMATTED.FILE.MCCS 73180 . 79413) -(\TEDIT.INTERPRET.MCCS.SHIFTS 79415 . 85660) (\TEDIT.CONVERT.XCCSTOMCCS 85662 . 86594)) (86618 92757 ( -\TEDIT.GET.UNFORMATTED.FILE.UTF8 86628 . 92755)) (92780 104122 (\TEDIT.GET.CHARLOOKS.LIST 92790 . -93521) (\TEDIT.GET.SINGLE.CHARLOOKS 93523 . 100595) (\TEDIT.GET.CHARLOOKS 100597 . 102153) ( -\TEDIT.GET.PARALOOKS.INDEX 102155 . 102699) (\TEDIT.GET.CHARLOOKS.INDEX 102701 . 104120)) (104123 -111780 (\TEDIT.GET.PARALOOKS.LIST 104133 . 104755) (\TEDIT.GET.SINGLE.PARALOOKS 104757 . 111778)) ( -111781 115614 (\TEDIT.GET.OBJECT 111791 . 115612)) (115679 148942 (\TEDIT.PUT.PCTB 115689 . 125596) ( -\TEDIT.PUT.PCTB.PIECEDATA 125598 . 128796) (\TEDIT.PUT.TRAILER 128798 . 130126) ( -\TEDIT.PUT.PCTB.MERGEABLE 130128 . 133901) (\TEDIT.PUT.UTF8.SPLITPIECES 133903 . 138605) ( -\TEDIT.PUT.PCTB.NEXTNEW 138607 . 143103) (\TEDIT.INSERT.NEWPIECES 143105 . 146540) (\TEDIT.PUTRESET -146542 . 146784) (\ARBOUT 146786 . 147510) (\ATMOUT 147512 . 148117) (\DWOUT 148119 . 148398) ( -\STRINGOUT 148400 . 148940)) (148943 161677 (\TEDIT.PUT.CHARLOOKS.LIST 148953 . 150625) ( -\TEDIT.PUT.SINGLE.CHARLOOKS 150627 . 156907) (\TEDIT.PUT.CHARLOOKS 156909 . 158248) ( -\TEDIT.PUT.CHARLOOKS1 158250 . 159301) (\TEDIT.PUT.OBJECT 159303 . 161675)) (161678 169317 ( -\TEDIT.PUT.PARALOOKS.LIST 161688 . 162590) (\TEDIT.PUT.SINGLE.PARALOOKS 162592 . 168176) ( -\TEDIT.PUT.PARALOOKS 168178 . 169315)) (169412 172841 (TEDITFROMLISPSOURCE 169422 . 172090) ( -SHELLSCRIPTP 172092 . 172321) (TEDITFROMSHELLSCRIPT 172323 . 172839))))) + (FILEMAP (NIL (5317 35576 (TEDIT.GET 5327 . 11737) (TEDIT.FORMATTEDFILEP 11739 . 13055) ( +TEDIT.FILEDATE 13057 . 14366) (TEDIT.INCLUDE 14368 . 22397) (TEDIT.RAW.INCLUDE 22399 . 23207) ( +TEDIT.PUT 23209 . 31565) (TEDIT.PUT.STREAM 31567 . 35574)) (35577 56851 (\TEDIT.GET.FOREIGN.FILE 35587 + . 39012) (\TEDIT.GET.UNFORMATTED.FILE 39014 . 43320) (\TEDIT.GET.FORMATTED.FILE 43322 . 46965) ( +\TEDIT.FORMATTEDSTREAMP 46967 . 50098) (\ARBIN 50100 . 50820) (\ATMIN 50822 . 51359) (\DWIN 51361 . +51740) (\STRINGIN 51742 . 52450) (\TEDIT.GET.TRAILER 52452 . 55320) (\TEDIT.CACHEFILE 55322 . 56849)) +(57017 73055 (\TEDIT.GET.PIECES3 57027 . 67990) (\TEDIT.GET.PROPS3 67992 . 71214) ( +\TEDIT.MAKE.STRINGPIECE 71216 . 73053)) (73056 86482 (\TEDIT.GET.UNFORMATTED.FILE.MCCS 73066 . 79299) +(\TEDIT.INTERPRET.MCCS.SHIFTS 79301 . 85546) (\TEDIT.CONVERT.XCCSTOMCCS 85548 . 86480)) (86504 92749 ( +\TEDIT.GET.UNFORMATTED.FILE.UTF8 86514 . 92747)) (92772 104114 (\TEDIT.GET.CHARLOOKS.LIST 92782 . +93513) (\TEDIT.GET.SINGLE.CHARLOOKS 93515 . 100587) (\TEDIT.GET.CHARLOOKS 100589 . 102145) ( +\TEDIT.GET.PARALOOKS.INDEX 102147 . 102691) (\TEDIT.GET.CHARLOOKS.INDEX 102693 . 104112)) (104115 +111772 (\TEDIT.GET.PARALOOKS.LIST 104125 . 104747) (\TEDIT.GET.SINGLE.PARALOOKS 104749 . 111770)) ( +111773 115606 (\TEDIT.GET.OBJECT 111783 . 115604)) (115671 148934 (\TEDIT.PUT.PCTB 115681 . 125588) ( +\TEDIT.PUT.PCTB.PIECEDATA 125590 . 128788) (\TEDIT.PUT.TRAILER 128790 . 130118) ( +\TEDIT.PUT.PCTB.MERGEABLE 130120 . 133893) (\TEDIT.PUT.UTF8.SPLITPIECES 133895 . 138597) ( +\TEDIT.PUT.PCTB.NEXTNEW 138599 . 143095) (\TEDIT.INSERT.NEWPIECES 143097 . 146532) (\TEDIT.PUTRESET +146534 . 146776) (\ARBOUT 146778 . 147502) (\ATMOUT 147504 . 148109) (\DWOUT 148111 . 148390) ( +\STRINGOUT 148392 . 148932)) (148935 161669 (\TEDIT.PUT.CHARLOOKS.LIST 148945 . 150617) ( +\TEDIT.PUT.SINGLE.CHARLOOKS 150619 . 156899) (\TEDIT.PUT.CHARLOOKS 156901 . 158240) ( +\TEDIT.PUT.CHARLOOKS1 158242 . 159293) (\TEDIT.PUT.OBJECT 159295 . 161667)) (161670 169309 ( +\TEDIT.PUT.PARALOOKS.LIST 161680 . 162582) (\TEDIT.PUT.SINGLE.PARALOOKS 162584 . 168168) ( +\TEDIT.PUT.PARALOOKS 168170 . 169307)) (169404 172833 (TEDITFROMLISPSOURCE 169414 . 172082) ( +SHELLSCRIPTP 172084 . 172313) (TEDITFROMSHELLSCRIPT 172315 . 172831))))) STOP diff --git a/library/tedit/TEDIT-FILE.LCOM b/library/tedit/TEDIT-FILE.LCOM index b68ce1d0b..6809340d3 100644 Binary files a/library/tedit/TEDIT-FILE.LCOM and b/library/tedit/TEDIT-FILE.LCOM differ diff --git a/library/virtualkeyboards/DANDELIONKEYBOARDS b/library/virtualkeyboards/DANDELIONKEYBOARDS index e958d19c0..4834b7da8 100644 --- a/library/virtualkeyboards/DANDELIONKEYBOARDS +++ b/library/virtualkeyboards/DANDELIONKEYBOARDS @@ -1,12 +1,10 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 6-Jul-2023 08:52:09" {WMEDLEY}virtualkeyboards>DANDELIONKEYBOARDS.;3 33795 +(FILECREATED "15-Oct-2025 16:50:39" {WMEDLEY}virtualkeyboards>DANDELIONKEYBOARDS.;4 33748 :EDIT-BY rmk - :CHANGES-TO (VARS DANDELIONKEYBOARDSCOMS) - - :PREVIOUS-DATE " 4-Jul-2023 23:18:05" {WMEDLEY}virtualkeyboards>DANDELIONKEYBOARDS.;2 + :PREVIOUS-DATE " 6-Jul-2023 08:52:09" {WMEDLEY}virtualkeyboards>DANDELIONKEYBOARDS.;3 ) @@ -324,7 +322,7 @@ (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) - (139 (9826 66 LOCKSHIFT)) + (139 (9826 9794 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) diff --git a/library/virtualkeyboards/XKEYBOARDS b/library/virtualkeyboards/XKEYBOARDS index 8442d293f..a035c92a9 100644 Binary files a/library/virtualkeyboards/XKEYBOARDS and b/library/virtualkeyboards/XKEYBOARDS differ diff --git a/sources/ADIR b/sources/ADIR index 944285b55..5dc4d1abc 100644 --- a/sources/ADIR +++ b/sources/ADIR @@ -1,10 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 6-Feb-2025 17:48:54" {DSK}frank>il>medley>sources>ADIR.;6 70091 +(FILECREATED "15-Oct-2025 15:20:48" {WMEDLEY}ADIR.;62 70135 - :CHANGES-TO (FNS INTERPRET.REM.CM) + :EDIT-BY rmk - :PREVIOUS-DATE "20-Jan-2025 13:37:28" {DSK}frank>il>medley>sources>ADIR.;3) + :CHANGES-TO (MACROS \UPF.EXTRACT) + + :PREVIOUS-DATE " 6-Feb-2025 17:48:54" {WMEDLEY}ADIR.;61) (PRETTYCOMPRINT ADIRCOMS) @@ -742,7 +744,8 @@ OFFST _ STARTOFFSET LENGTH _ (ADD1 (IDIFFERENCE ENDOFFSET STARTOFFSET)) BASE _ $$BASE - READONLY _ $$READONLY))) + READONLY _ $$READONLY + FATSTRINGP _ $$FATP))) (PUTPROPS \UPF.DIRTYPE MACRO [(DIRSTART) (* ; "Edited 20-Apr-2022 20:14 by rmk") (SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART) @@ -1279,14 +1282,14 @@ (ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3183 16010 (DELFILE 3193 . 3354) (FULLNAME 3356 . 3723) (INFILE 3725 . 3984) (INFILEP -3986 . 4121) (IOFILE 4123 . 4374) (OPENFILE 4376 . 4679) (OPENSTREAM 4681 . 9021) (OUTFILE 9023 . 9285 -) (OUTFILEP 9287 . 9423) (RENAMEFILE 9425 . 9731) (SIMPLE.FINDFILE 9733 . 10143) (VMEMSIZE 10145 . -10312) (\COPYSYS 10314 . 14605) (\FLUSHVM 14607 . 15679) (\LOGOUT0 15681 . 16008)) (16509 41169 ( -UNPACKFILENAME.STRING 16519 . 38355) (\UPF.DIRECTORY 38357 . 41167)) (42697 45003 (UNPACKFILENAME -42707 . 42893) (LASTCHPOS 42895 . 43589) (FILENAMEFIELD 43591 . 43885) (FILENAMEFIELD.STRING 43887 . -44291) (PACKFILENAME 44293 . 44636) (PACKFILENAME.STRING 44638 . 45001)) (59473 60386 ( -FILEDIRCASEARRAY 59483 . 60384)) (60553 67850 (LOGOUT 60563 . 61608) (MAKESYS 61610 . 63239) (SYSOUT -63241 . 64793) (SAVEVM 64795 . 65595) (HERALD 65597 . 65757) (INTERPRET.REM.CM 65759 . 67473) ( -\USEREVENT 67475 . 67848)) (68032 69759 (USERNAME 68042 . 68998) (SETUSERNAME 69000 . 69757))))) + (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))))) STOP diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM index 11d3df85e..8deb5dba3 100644 Binary files a/sources/ADIR.LCOM and b/sources/ADIR.LCOM differ diff --git a/sources/UFS b/sources/UFS index c2302b716..417e659ac 100644 --- a/sources/UFS +++ b/sources/UFS @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "18-Dec-2024 12:52:23" {WMEDLEY}UFS.;39 79633 +(FILECREATED "17-Oct-2025 08:49:57" {WMEDLEY}UFS.;60 91319 :EDIT-BY rmk - :CHANGES-TO (FNS \UFSRenameFile) + :CHANGES-TO (VARS UFSCOMS) + (FNS CHDIR) - :PREVIOUS-DATE "16-Sep-2023 09:22:55" {WMEDLEY}UFS.;38) + :PREVIOUS-DATE "16-Oct-2025 18:22:30" {WMEDLEY}UFS.;59) (PRETTYCOMPRINT UFSCOMS) @@ -14,6 +15,11 @@ (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)) @@ -130,6 +136,17 @@ (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) @@ -274,23 +291,160 @@ (DEFINEQ (\UFSOpenFile -(LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 6-Jun-90 12:18 by nm") (* ;;; "Open a file.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG ((ACC (SELECTQ ACCESS (INPUT ACCESS-INPUT) (OUTPUT ACCESS-OUTPUT) (BOTH ACCESS-BOTH) (APPEND ACCESS-APPEND) ACCESS-OTHER)) (REC (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (SELECTQ ACCESS (INPUT RECOG-OLD) (OUTPUT RECOG-NEW) ((BOTH APPEND) RECOG-NEW-OLD) RECOG-OTHER))) (EOF-FN (FUNCTION \EOSERROR)) (ERRNO (CREATECELL \FIXP)) OTHER FILEID BYTESIZE CDATE FULLNAME CINFO STRM CASE.CORRECT.NAME CASE.CORRECT.FULLFILENAME) (SETQ CASE.CORRECT.NAME (if (type? STREAM FILE) then (COND ((fetch (UFSSTREAM FILEID) of FILE) (* ; "Already open--this really ought to be an error") (RETURN FILE)) (T (LET ((FULLNAME (fetch (UFSSTREAM UNIXNAME) of FILE))) (SETQ STRM FILE) (* ; "Re use the old stream") (SUBSTRING FULLNAME (ADD1 (STRPOS "}" FULLNAME)))))) else (\UFS.RECOGNIZE.FILE FILE RECOG FDEV))) (COND ((NOT CASE.CORRECT.NAME) (RETURN NIL)) ((AND (NULL OLDSTREAM) (EQ (fetch (FDEV DEVICENAME) of FDEV) (QUOTE DSK)) (SETQ OTHER (\UFS.OPENP CASE.CORRECT.NAME FDEV)) (SELECTQ ACCESS (INPUT (* ; "ok if other file is also input") (DIRTYABLE OTHER)) T)) (* ; "Access conflict. Don't check this when just revalidating, of course. I also don't mess with this on UNIX device--let user get in trouble...") (CL:ERROR (QUOTE XCL:FILE-WONT-OPEN) :PATHNAME (\UFS.FULLNAME CASE.CORRECT.NAME FDEV)))) (SETQ CASE.CORRECT.FULLFILENAME (\UFS.ADD.HOST.FIELD CASE.CORRECT.NAME FDEV)) (* ;; "DSK cannot open a directory.") (AND (DSKP FDEV) (DIRECTORYNAMEP CASE.CORRECT.FULLFILENAME) (PROGN (PROMPTPRINT "{DSK} cannot open a directory file. Use {UNIX} device.") (\UFSError CASE.CORRECT.NAME 23 FDEV))) (SETQ CDATE (CREATECELL \FIXP)) (SETQ BYTESIZE (CREATECELL \FIXP)) (SETQ FILEID (OR (\UFSOpenFile-C CASE.CORRECT.FULLFILENAME REC ACC CDATE BYTESIZE ERRNO) (RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV)))) (if (= (IPLUS BYTESIZE 0) -1) then (SETQ EOF-FN (FUNCTION \DEVICEFILE.EOSERROR)) (SETQ BYTESIZE 0) elseif (EQ ACCESS (QUOTE OUTPUT)) then (SETQ BYTESIZE 0)) (if STRM then (replace (STREAM FULLFILENAME) of STRM with (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T)) (replace (STREAM DEVICE) of STRM with FDEV) (replace (STREAM EPAGE) of STRM with (FOLDLO BYTESIZE BYTESPERPAGE)) (replace (STREAM EOFFSET) of STRM with (IMOD BYTESIZE BYTESPERPAGE)) (replace (STREAM EOLCONVENTION) of STRM with (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO))) (replace (STREAM VALIDATION) of STRM with CDATE) (replace (STREAM ENDOFSTREAMOP) of STRM with EOF-FN) else (SETQ STRM (create STREAM FULLFILENAME _ (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T) DEVICE _ FDEV EPAGE _ (FOLDLO BYTESIZE BYTESPERPAGE) EOFFSET _ (IMOD BYTESIZE BYTESPERPAGE) EOLCONVENTION _ (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO)) VALIDATION _ CDATE ENDOFSTREAMOP _ EOF-FN))) (replace (UFSSTREAM FILEID) of STRM with FILEID) (replace (UFSSTREAM CDATE) of STRM with (if (SETQ CINFO (FASSOC (QUOTE CREATIONDATE) OTHERINFO)) then (IDATE (CADR CINFO)) else 0)) (replace (UFSSTREAM UNIXNAME) of STRM with CASE.CORRECT.FULLFILENAME) (* ; "Save the case sensitive full file name for closef & getfileinfo.") (RETURN STRM)))) -) + [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 16-Oct-2025 08:52 by rmk") + (* ; "Edited 6-Jun-90 12:18 by nm") + +(* ;;; "Open a file.") + + (WITH.MONITOR (\UFSGetMonitor FDEV) + (PROG ((ACC (SELECTQ ACCESS + (INPUT ACCESS-INPUT) + (OUTPUT ACCESS-OUTPUT) + (BOTH ACCESS-BOTH) + (APPEND ACCESS-APPEND) + ACCESS-OTHER)) + (REC (SELECTQ RECOG + (OLD RECOG-OLD) + (OLDEST RECOG-OLDEST) + (NEW RECOG-NEW) + (OLD/NEW RECOG-NEW-OLD) + (SELECTQ ACCESS + (INPUT RECOG-OLD) + (OUTPUT RECOG-NEW) + ((BOTH APPEND) + RECOG-NEW-OLD) + RECOG-OTHER))) + (EOF-FN (FUNCTION \EOSERROR)) + (ERRNO (CREATECELL \FIXP)) + OTHER FILEID BYTESIZE CDATE FULLNAME CINFO STRM CASE.CORRECT.NAME + CASE.CORRECT.FULLFILENAME) + + (* ;; "CASE.CORRECT.NAME is MCCS") + + (SETQ CASE.CORRECT.NAME (if (type? STREAM FILE) + then [COND + ((fetch (UFSSTREAM FILEID) of FILE) + (* ; + "Already open--this really ought to be an error") + (RETURN FILE)) + (T (LET ((FULLNAME (fetch (UFSSTREAM UNIXNAME) + of FILE))) + (SETQ STRM FILE) + (* ; "Re use the old stream") + (SUBSTRING FULLNAME (ADD1 (STRPOS "}" + FULLNAME] + else (\UFS.RECOGNIZE.FILE FILE RECOG FDEV))) + [COND + ((NOT CASE.CORRECT.NAME) + (RETURN NIL)) + ((AND (NULL OLDSTREAM) + (EQ (fetch (FDEV DEVICENAME) of FDEV) + 'DSK) + (SETQ OTHER (\UFS.OPENP CASE.CORRECT.NAME FDEV)) + (SELECTQ ACCESS + (INPUT (* ; "ok if other file is also input") + (DIRTYABLE OTHER)) + T)) (* ; "Access conflict. Don't check this when just revalidating, of course. I also don't mess with this on UNIX device--let user get in trouble...") + (CL:ERROR 'XCL:FILE-WONT-OPEN :PATHNAME (\UFS.FULLNAME CASE.CORRECT.NAME FDEV] + (SETQ CASE.CORRECT.FULLFILENAME (\UFS.ADD.HOST.FIELD CASE.CORRECT.NAME FDEV)) + + (* ;; "DSK cannot open a directory.") + + (AND (DSKP FDEV) + (DIRECTORYNAMEP CASE.CORRECT.FULLFILENAME) + (PROGN (PROMPTPRINT "{DSK} cannot open a directory file. Use {UNIX} device.") + (\UFSError CASE.CORRECT.NAME 23 FDEV))) + (SETQ CDATE (CREATECELL \FIXP)) + (SETQ BYTESIZE (CREATECELL \FIXP)) + [SETQ FILEID (OR (\UFSOpenFile-C (MTOUTF8STRING CASE.CORRECT.FULLFILENAME) + REC ACC CDATE BYTESIZE ERRNO) + (RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV] + (if (= (IPLUS BYTESIZE 0) + -1) + then (SETQ EOF-FN (FUNCTION \DEVICEFILE.EOSERROR)) + (SETQ BYTESIZE 0) + elseif (EQ ACCESS 'OUTPUT) + then (SETQ BYTESIZE 0)) + (if STRM + then (replace (STREAM FULLFILENAME) of STRM with (\UFS.FULLNAME CASE.CORRECT.NAME + FDEV T)) + (replace (STREAM DEVICE) of STRM with FDEV) + (replace (STREAM EPAGE) of STRM with (FOLDLO BYTESIZE BYTESPERPAGE)) + (replace (STREAM EOFFSET) of STRM with (IMOD BYTESIZE BYTESPERPAGE)) + (replace (STREAM EOLCONVENTION) of STRM with (\UFSeol CASE.CORRECT.NAME + (FASSOC 'TYPE OTHERINFO))) + (replace (STREAM VALIDATION) of STRM with CDATE) + (replace (STREAM ENDOFSTREAMOP) of STRM with EOF-FN) + else (SETQ STRM (create STREAM + FULLFILENAME _ (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T) + DEVICE _ FDEV + EPAGE _ (FOLDLO BYTESIZE BYTESPERPAGE) + EOFFSET _ (IMOD BYTESIZE BYTESPERPAGE) + EOLCONVENTION _ (\UFSeol CASE.CORRECT.NAME (FASSOC + 'TYPE OTHERINFO)) + VALIDATION _ CDATE + ENDOFSTREAMOP _ EOF-FN))) + (replace (UFSSTREAM FILEID) of STRM with FILEID) + (replace (UFSSTREAM CDATE) of STRM with (if (SETQ CINFO (FASSOC 'CREATIONDATE OTHERINFO + )) + then (IDATE (CADR CINFO)) + else 0)) + (replace (UFSSTREAM UNIXNAME) of STRM with CASE.CORRECT.FULLFILENAME) + (* ; + "Save the case sensitive full file name for closef & getfileinfo.") + (RETURN STRM)))]) (\UFS.OPENP (LAMBDA (UNIXNAME DEV) (* ; "Edited 3-Mar-89 11:47 by bvm") (* ;; "Returns first open file having specified unix name") (for S in (fetch (FDEV OPENFILELST) of DEV) bind (COMPAREFN _ (if (EQ (fetch (FDEV DEVICENAME) of DEV) (QUOTE DSK)) then (* ; "We're case-insensitive, and it seems like not all functions return the correct Unix case") (FUNCTION STRING-EQUAL) else (* ; "Exact") (FUNCTION STREQUAL))) thereis (CL:FUNCALL COMPAREFN UNIXNAME (fetch (UFSSTREAM UNIXNAME) of S)))) ) (\UFS.RECOGNIZE.FILE -(LAMBDA (FILENAME RECOG DEV) (* ; "Edited 13-Mar-90 11:19 by nm") (* ;; "Perform recognition on FILENAME, returning the %"true%" name for the file, or NIL. The result file name is following the Xerox Lisp file naming convention but does not include HOST field. It will be supplied by \UFS.FULLNAME.") (WITH.MONITOR (\UFSGetMonitor DEV) (LET ((NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (ERRNO (CREATECELL \FIXP)) LEN) (SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV) (\UFS.REMOVE.HOST.FIELD FILENAME DEV) (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (NON RECOG-NON) RECOG-NEW-OLD) NAMEAREA ERRNO)) (COND ((FIXP LEN) (SUBSTRING NAMEAREA 1 LEN)) (T (\UFSError FILENAME ERRNO)))))) -) + [LAMBDA (FILENAME RECOG DEV) (* ; "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") + + (* ;; "Perform recognition on FILENAME, returning the %"true%" name for the file, or NIL. The result file name is following the Xerox Lisp file naming convention but does not include HOST field. It will be supplied by \UFS.FULLNAME.") + + (WITH.MONITOR (\UFSGetMonitor DEV) + [LET ((NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) + (ERRNO (CREATECELL \FIXP)) + LEN) + (SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV) + (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD FILENAME DEV)) + (SELECTQ RECOG + (OLD RECOG-OLD) + (OLDEST RECOG-OLDEST) + (NEW RECOG-NEW) + (OLD/NEW RECOG-NEW-OLD) + (NON RECOG-NON) + RECOG-NEW-OLD) + NAMEAREA ERRNO)) + (COND + ((FIXP LEN) + (UTF8TOMSTRING (SUBSTRING NAMEAREA 1 LEN))) + (T (\UFSError FILENAME ERRNO])]) (\UFS.DIRECTORY.NAME -(LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 1-Apr-90 23:36 by nm") (* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"ture%" 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 %"ture%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.") (if (STREQUAL DIRSTRING "<") then (RPLSTRING NAMEAREA 1 "<") 1 else (WITH.MONITOR (\UFSGetMonitor DEV) (CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV) DIRSTRING NAMEAREA (CREATECELL \FIXP))))) -) + [LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "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") + + (if (STREQUAL DIRSTRING "<") + then (RPLSTRING NAMEAREA 1 "<") + 1 + else (WITH.MONITOR (\UFSGetMonitor DEV) + (CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV) + (MTOUTF8STRING DIRSTRING) + NAMEAREA + (CREATECELL \FIXP)))]) (\UFSCloseFile - [LAMBDA (STREAMFILE) (* ; "Edited 16-Sep-2023 09:21 by briggs") + [LAMBDA (STREAMFILE) (* ; "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") @@ -314,7 +468,8 @@ then (* ; "Open for output") (FDEVOP 'TRUNCATEFILE DEVICE STREAMFILE) (SETQ CDATE (fetch (UFSSTREAM CDATE) of STREAMFILE))) - (RETURN (if (\UFSCloseFile-C UNIXNAME (fetch (UFSSTREAM FILEID) of STREAMFILE) + (RETURN (if (\UFSCloseFile-C (MTOUTF8STRING UNIXNAME) + (fetch (UFSSTREAM FILEID) of STREAMFILE) CDATE ERRNO) then (replace (UFSSTREAM FILEID) of STREAMFILE with NIL) (replace (UFSSTREAM CDATE) of STREAMFILE with NIL) @@ -332,7 +487,8 @@ ) (\UFSRenameFile - [LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 18-Dec-2024 12:52 by rmk") + [LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "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) then @@ -349,8 +505,10 @@ (LET ((NEWUNIXNAME (\UFS.RECOGNIZE.FILE NEW-NAME 'NEW NEW-DEVICE)) (ERRNO (CREATECELL \FIXP))) (COND - ((\UFSRenameFile-C (\UFS.REMOVE.HOST.FIELD OLDUNIXNAME OLD-DEVICE) - (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME NEW-DEVICE) + ((\UFSRenameFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD + OLDUNIXNAME OLD-DEVICE)) + (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME + NEW-DEVICE)) NEW-DEVICE ERRNO) (\UFS.FULLNAME NEWUNIXNAME NEW-DEVICE)) (T (if (EQL (IPLUS ERRNO 0) @@ -372,32 +530,200 @@ ) (\UFSTruncateFile -(LAMBDA (STREAM PAGE# OFFSET) (* ; "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.") (\UPDATEOF STREAM) (OR (FIXP PAGE#) (SETQ PAGE# (fetch (STREAM EPAGE) of STREAM))) (OR (FIXP OFFSET) (SETQ OFFSET (fetch (STREAM EOFFSET) of STREAM))) (* ; "Truncate size was set to PAGE# and OFFSET") (PROG ((curEof (+ (UNFOLD (fetch (STREAM EPAGE) of STREAM) BYTESPERPAGE) (fetch (STREAM EOFFSET) of STREAM))) (needSize (+ (UNFOLD PAGE# BYTESPERPAGE) OFFSET)) (ERRNO (CREATECELL \FIXP))) (if (> needSize curEof) then (* ; "Push 0 to extend file.") (LET ((FILEPTR (\GETFILEPTR STREAM))) (\SETFILEPTR STREAM curEof) (to (- needSize curEof) do (\BOUT STREAM 0)) (\SETFILEPTR STREAM FILEPTR)) elseif T then (* ; "Call c to shorten file. It would be good if we kept track of the file's eof, so that we wouldn't have to do this on closef when nothing had changed") (OR (\UFSGetSize-C (fetch (UFSSTREAM FILEID) of STREAM) needSize ERRNO) (RETURN (\UFSError STREAM ERRNO))) else (RETURN)) (* ;; "Set new value to stream") (replace (STREAM EPAGE) of STREAM with PAGE#) (replace (STREAM EOFFSET) of STREAM with OFFSET) (LET ((DT (CREATECELL \FIXP))) (* ;; "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.") (if (\UFSGetFileInfo-C (fetch (UFSSTREAM UNIXNAME) of STREAM) ATTR-WDATE DT ERRNO) then (replace (STREAM VALIDATION) of STREAM with DT))))) -) + [LAMBDA (STREAM PAGE# OFFSET) (* ; "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.") + + (\UPDATEOF STREAM) + (OR (FIXP PAGE#) + (SETQ PAGE# (fetch (STREAM EPAGE) of STREAM))) + (OR (FIXP OFFSET) + (SETQ OFFSET (fetch (STREAM EOFFSET) of STREAM))) (* ; + "Truncate size was set to PAGE# and OFFSET") + (PROG ((curEof (+ (UNFOLD (fetch (STREAM EPAGE) of STREAM) + BYTESPERPAGE) + (fetch (STREAM EOFFSET) of STREAM))) + (needSize (+ (UNFOLD PAGE# BYTESPERPAGE) + OFFSET)) + (ERRNO (CREATECELL \FIXP))) + (if (> needSize curEof) + then (* ; "Push 0 to extend file.") + (LET ((FILEPTR (\GETFILEPTR STREAM))) + (\SETFILEPTR STREAM curEof) + (to (- needSize curEof) do (\BOUT STREAM 0)) + (\SETFILEPTR STREAM FILEPTR)) + else (* ; "Call c to shorten file. It would be good if we kept track of the file's eof, so that we wouldn't have to do this on closef when nothing had changed") + (OR (\UFSGetSize-C (fetch (UFSSTREAM FILEID) of STREAM) + needSize ERRNO) + (RETURN (\UFSError STREAM ERRNO))) + else (RETURN)) + + (* ;; "Set new value to stream") + + (replace (STREAM EPAGE) of STREAM with PAGE#) + (replace (STREAM EOFFSET) of STREAM with OFFSET) + (LET ((DT (CREATECELL \FIXP))) + + (* ;; + "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.") + + (if (\UFSGetFileInfo-C (MTOUTF8STRING (fetch (UFSSTREAM UNIXNAME) of STREAM)) + ATTR-WDATE DT ERRNO) + then (replace (STREAM VALIDATION) of STREAM with DT]) (\UFSDirectoryNameP -(LAMBDA (DIRSPEC DEV) (* ; "Edited 21-Sep-92 15:27 by jds") (* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.") (LET ((DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DEVICE)) "") (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DIRECTORY) (QUOTE RETURN)) (\UFS.HANDLE.RELATIVEDIRECTORY (UNPACKFILENAME.STRING DIRSPEC (QUOTE RELATIVEDIRECTORY) (QUOTE RETURN)) DEV) (\UFS.DEFAULT.DIR DEV)))) NAMEAREA LEN) (* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code. Thus we don't have to worry about the subdirectory case.") (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)) (COND ((FIXP LEN) (* ; "LEN holds the length of the %"true%" name of DIRECTORY.") (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN) DEV NIL)) (T NIL))) (T NIL)))) -) + [LAMBDA (DIRSPEC DEV) (* ; "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.") + + (LET ([DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC 'DEVICE) + "") + (OR (UNPACKFILENAME.STRING DIRSPEC 'DIRECTORY 'RETURN) + (\UFS.HANDLE.RELATIVEDIRECTORY (UNPACKFILENAME.STRING DIRSPEC + 'RELATIVEDIRECTORY + 'RETURN) + DEV) + (\UFS.DEFAULT.DIR DEV] + NAMEAREA LEN) + + (* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code. Thus we don't have to worry about the subdirectory case.") + + (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)) + (COND + ((FIXP LEN) (* ; + "LEN holds the length of the %"true%" name of DIRECTORY.") + (UTF8TOMSTRING (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN) + DEV NIL))) + (T NIL))) + (T NIL]) (\UFSEventFn (LAMBDA (Dev Event) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 3-May-90 17:35 by nm") (WITH.MONITOR \UFStopMonitor (SELECTQ Event ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (\UFSCloseDevice) (SELECTQ (MACHINETYPE) ((MAIKO) (\UFSOpenDevice) (* ;; "revalidate open streams (should probably move this into the SELECTQ above) ") (\UNVISIBLE.PAGED.REVALIDATEFILELST Dev) (\PAGED.REVALIDATEFILELST Dev) (MAPHASH \UFS.GFS.TABLE (FUNCTION (LAMBDA (VAL KEY) (\UFS.UNREGISTER.GFS VAL)))) (CLRHASH \UFS.GFS.TABLE)) NIL)) ((BEFORELOGOUT) (\UNVISIBLE.FLUSH.OPEN.STREAMS Dev) (* ; "flush output buffers.") (\FLUSH.OPEN.STREAMS Dev)) NIL))) ) (\UFSGetFileInfo -(LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 30-Mar-90 12:27 by nm") (* ;;; "Get the value of the attribute for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.") (* ;;; "Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE) (if FILENAME then (SELECTQ ATTRIBUTE (LENGTH (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (SIZE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then (FOLDHI BUFFER BYTESPERPAGE) else (\UFSError FILENAME ERRNO DEVICE))) (TYPE (\UFSGetFileType FILENAME)) ((CREATIONDATE WRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) (READDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) ((ICREATIONDATE IWRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (IREADDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER ERRNO)) then (CL:SUBSEQ BUFFER 0 NAMESIZE) else (\UFSError FILENAME ERRNO DEVICE))) (PROTECTION (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (ALL (SETQ BUFFER (\UFS.CREATE.PROPS)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO)) then (LET ((ALIST (ASSOC (QUOTE AUTHOR) BUFFER))) (* ; "Copy string out of buffer") (RPLACD ALIST (CL:SUBSEQ (CDR ALIST) 0 NAMESIZE)) BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) NIL))))) -) + [LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "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.") + +(* ;;; "Allocate buffer to store the value.") + +(* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.") + +(* ;;; "Otherwise the type of the buffer is FIXP.") + + (WITH.MONITOR (\UFSGetMonitor DEVICE) + (LET ((FILENAME (if (type? STREAM STREAM) + then (fetch (UFSSTREAM UNIXNAME) of STREAM) + else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM 'OLD DEVICE) + DEVICE NIL))) + (ERRNO (CREATECELL \FIXP)) + BUFFER NAMESIZE) + (if FILENAME + then (SETQ FILENAME (MTOUTF8STRING FILENAME)) + (SELECTQ ATTRIBUTE + (LENGTH (SETQ BUFFER (CREATECELL \FIXP)) + (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) + then BUFFER + else (\UFSError FILENAME ERRNO DEVICE))) + (SIZE (SETQ BUFFER (CREATECELL \FIXP)) + (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) + then (FOLDHI BUFFER BYTESPERPAGE) + else (\UFSError FILENAME ERRNO DEVICE))) + (TYPE (\UFSGetFileType FILENAME)) + ((CREATIONDATE WRITEDATE) + (SETQ BUFFER (CREATECELL \FIXP)) + (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) + then (GDATE BUFFER) + else (\UFSError FILENAME ERRNO DEVICE))) + (READDATE (SETQ BUFFER (CREATECELL \FIXP)) + (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) + then (GDATE BUFFER) + else (\UFSError FILENAME ERRNO DEVICE))) + ((ICREATIONDATE IWRITEDATE) + (SETQ BUFFER (CREATECELL \FIXP)) + (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) + then BUFFER + else (\UFSError FILENAME ERRNO DEVICE))) + (IREADDATE (SETQ BUFFER (CREATECELL \FIXP)) + (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) + then BUFFER + else (\UFSError FILENAME ERRNO DEVICE))) + (AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN)) + (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER + ERRNO)) + then (UTF8TOMSTRING (CL:SUBSEQ BUFFER 0 NAMESIZE)) + else (\UFSError FILENAME ERRNO DEVICE))) + (PROTECTION (SETQ BUFFER (CREATECELL \FIXP)) + (if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO) + then BUFFER + else (\UFSError FILENAME ERRNO DEVICE))) + (ALL (SETQ BUFFER (\UFS.CREATE.PROPS)) + (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO)) + then (LET ((ALIST (ASSOC 'AUTHOR BUFFER))) + (* ; "Copy string out of buffer") + (RPLACD ALIST (CL:SUBSEQ (CDR ALIST) + 0 NAMESIZE)) + BUFFER) + else (\UFSError FILENAME ERRNO DEVICE))) + NIL))))]) (\UFS.CREATE.PROPS (LAMBDA NIL (* ; "Edited 2-Mar-89 12:10 by bvm") (* ;; "Returns a data structure suitable for passing to the GetFileInfo ALL routine") (BQUOTE ((LENGTH (\,@ (CREATECELL \FIXP))) (WDATE (\,@ (CREATECELL \FIXP))) (RDATE (\,@ (CREATECELL \FIXP))) (PROTECTION (\,@ (CREATECELL \FIXP))) (AUTHOR (\,@ (ALLOCSTRING MAX-UNAME-LEN)))))) ) (\UFSSetFileInfo -(LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 30-Mar-90 12:31 by nm") (* ;;; "Get the VALUE of the ATTRIBUTE for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTOR, the type of the buffer is STRING.") (* ;;; " Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE PATHNAME) (if FILENAME then (SELECTQ ATTRIBUTE (TYPE (\UFSSetFileType FILENAME VALUE)) ((CREATIONDATE WRITEDATE) (if (AND (STRINGP VALUE) (SETQ VALUE (IDATE VALUE))) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) ((ICREATIONDATE IWRITEDATE) (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) (PROTECTION (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) NIL))))) -) + [LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "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.") + +(* ;;; "Allocate buffer to store the value.") + +(* ;;; "If attribute is AUTOR, the type of the buffer is STRING.") + +(* ;;; " Otherwise the type of the buffer is FIXP.") + + (WITH.MONITOR (\UFSGetMonitor DEVICE) + (LET ((FILENAME (if (type? STREAM STREAM) + then (fetch (UFSSTREAM UNIXNAME) of STREAM) + else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM 'OLD DEVICE) + DEVICE NIL))) + (ERRNO (CREATECELL \FIXP)) + BUFFER NAMESIZE PATHNAME) + (if FILENAME + then (SETQ FILENAME (MTOUTF8STRING FILENAME)) + (SELECTQ ATTRIBUTE + (TYPE (\UFSSetFileType FILENAME VALUE)) + ((CREATIONDATE WRITEDATE) + (if (AND (STRINGP VALUE) + (SETQ VALUE (IDATE VALUE))) + then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) + (\UFSError FILENAME ERRNO DEVICE)) + else (ERROR "Invalid argument" VALUE))) + ((ICREATIONDATE IWRITEDATE) + (if (FIXP VALUE) + then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) + (\UFSError FILENAME ERRNO DEVICE)) + else (ERROR "Invalid argument" VALUE))) + (PROTECTION (if (FIXP VALUE) + then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE + ERRNO) + (\UFSError FILENAME ERRNO DEVICE)) + else (ERROR "Invalid argument" VALUE))) + NIL))))]) (\UFSGenerateFiles [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) + (* ;; "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") (* ;; "rmk; Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults") @@ -435,19 +761,22 @@ (COND ((STREQUAL DIRECTORY "/") (SETQ DIRECTORY "<"))) - [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] + + (* ;; "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 LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "") DIRECTORY) NAMEAREA FDEV)) @@ -455,7 +784,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)) + (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ; "DIRECTORY is now UTF8") (* ;; "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.") @@ -466,7 +795,8 @@ (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (COND [(< TOTALNUM 0) - (OR (\UFSError DIRECTORY ERRNO FDEV) + (OR (\UFSError (UTF8TOMSTRING DIRECTORY) + ERRNO FDEV) (RETURN (\NULLFILEGENERATOR] (T (COND ((ZEROP TOTALNUM) @@ -475,6 +805,9 @@ (EQ OPTIONS 'RESETLST)) (FMEMB 'RESETLST OPTIONS)) (RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID] + + (* ;; "Everything in FILEGENOBJ is UTF8") + (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) @@ -496,24 +829,31 @@ CURRENT-DEPTH _ 1 MAX-DEPTH _ FILING.ENUMERATION.DEPTH - FILTER _ ( - PACKFILENAME.STRING - 'NAME NAME - 'EXTENSION - EXTENSION - 'VERSION VERSION]) - ]) + FILTER _ + (PACKFILENAME.STRING + 'NAME + (AND NAME (MTOUTF8STRING + NAME)) + 'EXTENSION + (AND EXTENSION ( + MTOUTF8STRING + EXTENSION)) + 'VERSION VERSION])]) (\UFS.NEXTFILEFN [LAMBDA (GENFILESTATE NAMEONLY) + (* ;; "Edited 16-Oct-2025 16:59 by rmk") + (* ;;  "Edited 27-Mar-2022 21:59 by rmk: Add FILTER to construct proper generator for subdirectories") (* ;; "Edited 7-Oct-93 14:31 by jds") (* ;; "Given a UFS filesystem generator, return the %"next%" file in line.") - (* ; "") + + (* ;; "All the fields of the UFSGENFILESTATE are UTF8. FILENAME is MCCS") + (LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE)) FILENAME NAMELEN NEWNAME) (COND @@ -556,6 +896,9 @@ GENFILESTATE ) 0 NAMELEN)) + + (* ;; "NEWNAME and DIRECTORY are both UTF8") + (SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY) of GENFILESTATE) NEWNAME @@ -607,8 +950,8 @@ (* ;; "We're set up to recurse into the SUBGEN above") (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY)) - (NAMEONLY NEWNAME) - (T FILENAME))) + (NAMEONLY (UTF8TOMSTRING NEWNAME)) + (T (UTF8TOMSTRING FILENAME)))) (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))]) (\UFS.FILEINFOFN @@ -720,8 +1063,25 @@ (DEFINEQ (CHDIR -(LAMBDA (PATHNAME) (* ; "Edited 2-Apr-90 01:07 by nm") (* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.") (WITH.MONITOR \UFStopMonitor (LET ((PATH (\ADD.CONNECTED.DIR PATHNAME)) HOST) (if PATH then (SETQ HOST (U-CASE (FILENAMEFIELD PATH (QUOTE HOST)))) (if (OR (EQ HOST (QUOTE DSK)) (EQ HOST (QUOTE UNIX))) then (if (SETQ PATH (DIRECTORYNAME PATH)) then (if (\UFSCHDIR-C PATH) then (DIRECTORYNAME PATH) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "Bad Host Name" HOST)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))))) -) + [LAMBDA (PATHNAME) (* ; "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.") + + (WITH.MONITOR \UFStopMonitor + (LET ((PATH (\ADD.CONNECTED.DIR PATHNAME)) + HOST) + (if PATH + then [SETQ HOST (U-CASE (FILENAMEFIELD PATH 'HOST] + (if (OR (EQ HOST 'DSK) + (EQ HOST 'UNIX)) + then (if (SETQ PATH (DIRECTORYNAME PATH)) + then (if (\UFSCHDIR-C (MTOUTF8STRING PATH)) + then (DIRECTORYNAME PATH) + else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) + else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) + else (ERROR "Bad Host Name" HOST)) + else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))))]) ) @@ -1184,23 +1544,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (8857 10410 (\UFSCreateDevice 8867 . 9232) (\UFS.CREATE.DEVICE 9234 . 10090) ( -\UFSOpenDevice 10092 . 10269) (\UFSCloseDevice 10271 . 10408)) (14673 52047 (\UFSOpenFile 14683 . -17977) (\UFS.OPENP 17979 . 18476) (\UFS.RECOGNIZE.FILE 18478 . 19231) (\UFS.DIRECTORY.NAME 19233 . -19976) (\UFSCloseFile 19978 . 21883) (\UFSGetFileName 21885 . 22084) (\UFSDeleteFile 22086 . 22626) ( -\UFSRenameFile 22628 . 24665) (\UFSReadPages 24667 . 25802) (\UFSWritePages 25804 . 27024) ( -\UFSTruncateFile 27026 . 28523) (\UFSDirectoryNameP 28525 . 29579) (\UFSEventFn 29581 . 30243) ( -\UFSGetFileInfo 30245 . 32527) (\UFS.CREATE.PROPS 32529 . 32882) (\UFSSetFileInfo 32884 . 34113) ( -\UFSGenerateFiles 34115 . 40995) (\UFS.NEXTFILEFN 40997 . 48635) (\UFS.FILEINFOFN 48637 . 50086) ( -\UFS.VALID.PROPP 50088 . 50380) (\UFS.REGISTER.GFS 50382 . 50637) (\UFS.UNREGISTER.GFS 50639 . 51222) -(\UFS.ABORT.DIRECTORY 51224 . 51572) (\UFS.ABORT.CL-DIRECTORY 51574 . 51861) (\UFS.CLEANUP.GFS.TABLE -51863 . 52045)) (52082 58766 (\UFSMakeUnixFormatName 52092 . 53113) (\UFSParseNameString 53115 . 53489 -) (\UFSParse-Directory 53491 . 54032) (\UFS.PARSE.BODY 54034 . 54579) (\UFS.ADJUST.HOST 54581 . 54740) - (\UFS.FULLNAME 54742 . 55950) (\UFS.ADD.HOST.FIELD 55952 . 56312) (\UFS.REMOVE.HOST.FIELD 56314 . -57984) (\UFS.HANDLE.RELATIVEDIRECTORY 57986 . 58764)) (59582 60195 (CHDIR 59592 . 60193)) (60267 61253 - (\DEVICEFILE.EOSERROR 60277 . 61251)) (61326 62563 (\UNVISIBLE.PAGED.REVALIDATEFILELST 61336 . 62181) - (\UNVISIBLE.FLUSH.OPEN.STREAMS 62183 . 62561)) (62596 64222 (\UFSError 62606 . 64220)) (64266 66681 ( -\UFSGetFileType 64276 . 64877) (\UFSSetFileType 64879 . 65476) (\UFSeol 65478 . 66679)) (75328 76452 ( -\UFSGetPrintFileType 75338 . 75750) (\UFSGetFileTypeConfirm 75752 . 76200) (\UFSPrintTypeMenu 76202 . -76450)) (76482 79320 (\UFStoOtherCopyMess 76492 . 78170) (\UFStoOtherRenameMess 78172 . 79318))))) + (FILEMAP (NIL (9345 10898 (\UFSCreateDevice 9355 . 9720) (\UFS.CREATE.DEVICE 9722 . 10578) ( +\UFSOpenDevice 10580 . 10757) (\UFSCloseDevice 10759 . 10896)) (15161 63201 (\UFSOpenFile 15171 . +21747) (\UFS.OPENP 21749 . 22246) (\UFS.RECOGNIZE.FILE 22248 . 23678) (\UFS.DIRECTORY.NAME 23680 . +24770) (\UFSCloseFile 24772 . 26831) (\UFSGetFileName 26833 . 27032) (\UFSDeleteFile 27034 . 27574) ( +\UFSRenameFile 27576 . 29893) (\UFSReadPages 29895 . 31030) (\UFSWritePages 31032 . 32252) ( +\UFSTruncateFile 32254 . 34660) (\UFSDirectoryNameP 34662 . 36525) (\UFSEventFn 36527 . 37189) ( +\UFSGetFileInfo 37191 . 41654) (\UFS.CREATE.PROPS 41656 . 42009) (\UFSSetFileInfo 42011 . 44357) ( +\UFSGenerateFiles 44359 . 51971) (\UFS.NEXTFILEFN 51973 . 59789) (\UFS.FILEINFOFN 59791 . 61240) ( +\UFS.VALID.PROPP 61242 . 61534) (\UFS.REGISTER.GFS 61536 . 61791) (\UFS.UNREGISTER.GFS 61793 . 62376) +(\UFS.ABORT.DIRECTORY 62378 . 62726) (\UFS.ABORT.CL-DIRECTORY 62728 . 63015) (\UFS.CLEANUP.GFS.TABLE +63017 . 63199)) (63236 69920 (\UFSMakeUnixFormatName 63246 . 64267) (\UFSParseNameString 64269 . 64643 +) (\UFSParse-Directory 64645 . 65186) (\UFS.PARSE.BODY 65188 . 65733) (\UFS.ADJUST.HOST 65735 . 65894) + (\UFS.FULLNAME 65896 . 67104) (\UFS.ADD.HOST.FIELD 67106 . 67466) (\UFS.REMOVE.HOST.FIELD 67468 . +69138) (\UFS.HANDLE.RELATIVEDIRECTORY 69140 . 69918)) (70736 71881 (CHDIR 70746 . 71879)) (71953 72939 + (\DEVICEFILE.EOSERROR 71963 . 72937)) (73012 74249 (\UNVISIBLE.PAGED.REVALIDATEFILELST 73022 . 73867) + (\UNVISIBLE.FLUSH.OPEN.STREAMS 73869 . 74247)) (74282 75908 (\UFSError 74292 . 75906)) (75952 78367 ( +\UFSGetFileType 75962 . 76563) (\UFSSetFileType 76565 . 77162) (\UFSeol 77164 . 78365)) (87014 88138 ( +\UFSGetPrintFileType 87024 . 87436) (\UFSGetFileTypeConfirm 87438 . 87886) (\UFSPrintTypeMenu 87888 . +88136)) (88168 91006 (\UFStoOtherCopyMess 88178 . 89856) (\UFStoOtherRenameMess 89858 . 91004))))) STOP diff --git a/sources/UFS.LCOM b/sources/UFS.LCOM index 850c76eff..bebc5d6c9 100644 Binary files a/sources/UFS.LCOM and b/sources/UFS.LCOM differ