diff --git a/library/UNICODE b/library/UNICODE
index 290a1711..6975d3d9 100644
--- a/library/UNICODE
+++ b/library/UNICODE
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "17-Aug-2020 08:48:36" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNICODE.;166 65800  

      changes to%:  (FNS UTF8.OUTCHARFN UTF16BE.OUTCHARFN MAKE-UNICODE-TRANSLATION-TABLES)

      previous date%: "16-Aug-2020 23:24:01" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNICODE.;165)


(PRETTYCOMPRINT UNICODECOMS)

(RPAQQ UNICODECOMS
       [(COMS 
              (* ;; "External formats")

              (FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCHARFN)
              (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCHARFN)
              (INITVARS (EXTERNALEOL 'LF))
              (FNS MAKE-UNICODE-FORMATS)
              (P (MAKE-UNICODE-FORMATS EXTERNALEOL))
              (ADDVARS (*DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8)))
              (FNS UNICODE.UNMAPPED)
              (FNS XCCS-UTF8-AFTER-OPEN)
              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE))
              (FNS XTOUCODE UTOXCODE))
        [COMS 
              (* ;; "Unicode mapping files")

              (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING 
                   WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME
                   )
              (VARS XCCS-SET-NAMES)
              
              (* ;; "Automate dumping of a documentation prefix")

              [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" 
                                                                              :RADIX 16))
                                                      (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX
                                                                            16]
              (VARS UNICODE-MAPPING-HEADER)
              (INITVARS (UNICODEDIRECTORIES NIL))
              (P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR")
                                                    '/lispcore/unicode/xerox/]
        (COMS 
              (* ;; "Set up translation tables for UTF8 and UTFBE external formats")

              (FNS MAKE-UNICODE-TRANSLATION-TABLES)
              [INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS 
                                                       SYMBOLS3 SYMBOLS4 ACCENTED-LATIN]
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES (
                                                                                 READ-UNICODE-MAPPING
                                                                                   
                                                                                DEFAULT-XCCS-CHARSETS
                                                                                   T)
                                                        '*XCCSTOUNICODE*
                                                        '*UNICODETOXCCS*]
              (GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*))
        (FNS HEXSTRING UTF8HEXSTRING NUTF8CODEBYTES NUTF8STRINGBYTES XTOUSTRING XCCSSTRING)
        (FNS SHOWCHARS)
        (DECLARE%: EVAL@COMPILE DONTCOPY 

               (* ;; "This is taken from FILEIO")

               (CONSTANTS (LF.EOLC 1)
                      (CR.EOLC 0)
                      (CRLF.EOLC 2))
               
               (* ;; "These control the layout of the translation tables.  Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter")

               (CONSTANTS (TRANSLATION-SEGMENT-SIZE 128)
                      (MAX-ALIST-LENGTH 10)
                      (N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE))
                      (TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE)))
                      (TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE)))
               (P (EVAL (SYSRECLOOK1 'EXTERNALFORMAT))
                  (EVAL (SYSRECLOOK1 'STREAM])



(* ;; "External formats")

(DEFINEQ

(UTF8.OUTCHARFN
  [LAMBDA (STREAM CHARCODE RAW)                         (* ; "Edited 17-Aug-2020 08:45 by rmk:")
                                                            (* ; "Edited 30-Jan-2020 23:08 by rmk:")

    (* ;; "PRINT UTF8 sequence for CHARCODE.  Do not do XCCS to Unicode translation of RAW.")

    (CHANGE (FETCH (STREAM CHARPOSITION) OF STREAM)
           (CL:IF (EQ CHARCODE (CHARCODE EOL))
               0
               (IPLUS DATUM 1)))                             (* ; "Avoid overflow")
    (FOR C INSIDE (CL:IF RAW
                              CHARCODE
                              (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*))
       DO (IF (ILESSP C 128)
                  THEN (\BOUT STREAM C)
                ELSEIF (ILESSP C 2048)
                  THEN                                   (* ; "x800")
                        (\BOUT STREAM (LOGOR (LLSH 3 6)
                                             (LRSH C 6)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 0 6)))
                ELSEIF (ILESSP C 65536)
                  THEN                                   (* ; "x10000")
                        (\BOUT STREAM (LOGOR (LLSH 7 5)
                                             (LRSH C 12)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 6 6)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 0 6)))
                ELSEIF (ILESSP C 2097152)
                  THEN                                   (* ; "x200000")
                        (\BOUT STREAM (LOGOR (LLSH 15 4)
                                             (LRSH C 18)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 12 6)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 6 6)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 0 6)))
                ELSE (ERROR "CHARCODE too big for UTF8" C])

(UTF8.INCCODEFN
  [LAMBDA (STREAM COUNTP RAW)                           (* ; "Edited  6-Aug-2020 17:13 by rmk:")

    (* ;; "Do not do UNICODE to XCSS translation if RAW.")

    (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error")

    (LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT 1))
         (SETQ BYTE1 (\BIN STREAM))

         (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1")

         (CL:WHEN (SMALLP BYTE1)
             [SETQ CODE (IF (ILESSP BYTE1 128)
                            THEN 

                                  (* ;; "Test first:  Ascii is the common case")

                                  BYTE1
                          ELSEIF (IGEQ BYTE1 (LLSH 15 4))
                            THEN                         (* ; "4 bytes")
                                  (SETQ BYTE2 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE2))
                                               (ILESSP BYTE2 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                                  (SETQ BYTE3 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE3))
                                               (ILESSP BYTE3 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
                                  (SETQ BYTE4 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE4))
                                               (ILESSP BYTE4 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4)))
                                  (SETQ COUNT 4)
                                  (LOGOR (LLSH (LOADBYTE BYTE1 0 3)
                                               18)
                                         (LLSH (LOADBYTE BYTE2 0 6)
                                               12)
                                         (LLSH (LOADBYTE BYTE3 0 6)
                                               6)
                                         (LOADBYTE BYTE4 0 6))
                          ELSEIF (IGEQ BYTE1 (LLSH 7 5))
                            THEN                         (* ; "3 bytes")
                                  (SETQ BYTE2 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE2))
                                               (ILESSP BYTE2 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                                  (SETQ BYTE3 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE3))
                                               (ILESSP BYTE3 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
                                  (SETQ COUNT 3)
                                  (LOGOR (LLSH (LOADBYTE BYTE1 0 4)
                                               12)
                                         (LLSH (LOADBYTE BYTE2 0 6)
                                               6)
                                         (LOADBYTE BYTE3 0 6))
                          ELSE                           (* ; "Must be 2 bytes")
                                (SETQ COUNT 2)
                                (SETQ BYTE2 (\BIN STREAM))
                                (CL:WHEN (OR (NOT (SMALLP BYTE2))
                                             (ILESSP BYTE2 128))
                                    (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                                (LOGOR (LLSH (LOADBYTE BYTE1 0 5)
                                             6)
                                       (LOADBYTE BYTE2 0 6])
         (CL:UNLESS (OR RAW (NOT (SMALLP CODE)))
             (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)))
         (CL:IF COUNTP
             (CL:VALUES CODE COUNT)
             CODE)])

(UTF8.PEEKCCODEFN
  [LAMBDA (STREAM NOERROR COUNTP RAW)                   (* ; "Edited  6-Aug-2020 17:12 by rmk:")

    (* ;; "Modeled this after \EUCPEEK on LLREAD.  In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0.  Returns NIL if NOERROR and either invalid UTF8 or end of file.")

    (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.")

    (* ;; "Do not do UNICODE to XCCS translation if RAW")

    (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE)
          (SETQ BYTE1 (\PEEKBIN STREAM NOERROR))

     (* ;; "Distinguish on header bytex")

          (CL:UNLESS BYTE1
              (RETURN (AND COUNTP (CL:VALUES NIL 0))))
          [IF (ILESSP BYTE1 128)
              THEN 

                    (* ;; 
                  "Test first:  Ascii is the common case.  No need to back up, since we peeked.")

                    (SETQ CODE BYTE1)
            ELSEIF (IGEQ BYTE1 (LLSH 15 4))
              THEN                                       (* ; "4 bytes")
                    (\BIN STREAM)
                    (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
                                    (IGEQ BYTE2 128))
                        (\BACKFILEPTR STREAM)
                        (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                        (RETURN (IF COUNTP
                                    THEN (CL:VALUES CODE 0)
                                  ELSE CODE)))
                    (\BIN STREAM)
                    (CL:UNLESS (AND (SETQ BYTE3 (\PEEKBIN STREAM NOERROR))
                                    (IGEQ BYTE3 128))
                        (\BACKFILEPTR STREAM)
                        (\BACKFILEPTR STREAM)
                        (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
                        (RETURN (IF COUNTP
                                    THEN (CL:VALUES CODE 0)
                                  ELSE CODE)))
                    (\BIN STREAM)
                    (SETQ BYTE4 (\PEEKBIN STREAM NOERROR))   (* ; 
                                                           "PEEK the last, no need to back it up")
                    (\BACKFILEPTR STREAM)
                    (\BACKFILEPTR STREAM)
                    (\BACKFILEPTR STREAM)
                    (IF (AND BYTE4 (IGEQ BYTE4 128))
                        THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 3)
                                                         18)
                                                   (LLSH (LOADBYTE BYTE2 0 6)
                                                         12)
                                                   (LLSH (LOADBYTE BYTE3 0 6)
                                                         6)
                                                   (LOADBYTE BYTE4 0 6)))
                      ELSEIF NOERROR
                      ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4)))
            ELSEIF (IGEQ BYTE1 (LLSH 7 5))
              THEN                                       (* ; "3 bytes")
                    (\BIN STREAM)
                    (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
                                    (IGEQ BYTE2 128))
                        (\BACKFILEPTR STREAM)
                        (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                        (RETURN (IF COUNTP
                                    THEN (CL:VALUES CODE 0)
                                  ELSE CODE)))
                    (\BIN STREAM)
                    (SETQ BYTE3 (\PEEKBIN STREAM NOERROR))
                    (\BACKFILEPTR STREAM)
                    (\BACKFILEPTR STREAM)
                    (IF (AND BYTE3 (IGEQ BYTE3 128))
                        THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 4)
                                                         12)
                                                   (LLSH (LOADBYTE BYTE2 0 6)
                                                         6)
                                                   (LOADBYTE BYTE3 0 6)))
                      ELSEIF NOERROR
                      ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
            ELSE                                         (* ; "Must be 2 bytes")
                  (\BIN STREAM)
                  (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
                  (\BACKFILEPTR STREAM)
                  (IF (AND BYTE2 (IGEQ BYTE2 128))
                      THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5)
                                                       6)
                                                 (LOADBYTE BYTE2 0 6)))
                    ELSEIF NOERROR
                    ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2]
          (CL:WHEN (AND CODE (NOT RAW))
              (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)))
          (RETURN (IF COUNTP
                      THEN (CL:VALUES CODE 0)
                    ELSE CODE])

(\UTF8.BACKCHARFN
  [LAMBDA (STREAM COUNTP)                               (* ; "Edited 26-Jul-2020 10:41 by rmk:")

    (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT")

    (BIND (C _ 0) WHILE (CL:WHEN (\BACKFILEPTR STREAM)
                                    (ADD C 1)
                                    (EQ 2 (LRSH (\PEEKBIN STREAM)
                                                6))) REPEATUNTIL (EQ C 4)
       FINALLY (RETURN (AND COUNTP C])
)
(DEFINEQ

(UTF16BE.OUTCHARFN
  [LAMBDA (STREAM CHARCODE RAW)                         (* ; "Edited 17-Aug-2020 08:48 by rmk:")
                                                            (* ; "Edited 30-Jan-2020 23:08 by rmk:")

    (* ;; "PRINT UTF16 sequence for CHARCODE.  Do not do XCCS to UNICODE translation if RAW.")

    (CHANGE (FETCH (STREAM CHARPOSITION) OF STREAM)
           (CL:IF (EQ CHARCODE (CHARCODE EOL))
               0
               (IPLUS DATUM 1)))
    (FOR C INSIDE (CL:IF RAW
                              CHARCODE
                              (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*))
       DO (\BOUT STREAM (LRSH C 8))
             (\BOUT STREAM (LOGAND C 255])

(UTF16BE.INCCODEFN
  [LAMBDA (STREAM COUNTP RAW)                           (* ; "Edited  6-Aug-2020 17:48 by rmk:")

    (* ;; 
  "Do not do UNICODE to XCCS translation if RAW.  Test for SMALLPin case of funky EOF behavior")

    (LET (CODE BYTE1 BYTE2 COUNT)
         (IF [AND (SMALLP (SETQ BYTE1 (\BIN STREAM)))
                      (SMALLP (SETQ BYTE2 (\BIN STREAM]
             THEN (SETQ COUNT 2)
                   (SETQ CODE (LOGOR (LLSH (\BIN STREAM)
                                           8)
                                     (\BIN STREAM)))
                   (CL:UNLESS RAW
                       (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)))
                   (CL:IF COUNTP
                       (CL:VALUES CODE COUNT)
                       CODE)
           ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM])

(UTF16BE.PEEKCCODEFN
  [LAMBDA (STREAM NOERROR COUNTP RAW)                   (* ; "Edited 30-Jul-2020 14:06 by rmk:")

    (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.")

    (* ;; "Do not do UNICODE to XCCS translation if RAW")

    (LET (BYTE1 BYTE2 CODE)
         (SETQ BYTE1 (\PEEKBIN STREAM NOERROR))
         (IF BYTE1
             THEN (\BIN STREAM)
                   (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
                   (\BACKFILEPTR STREAM)
                   (IF BYTE2
                       THEN (SETQ CODE (LOGOR (LLSH BYTE1 8)
                                                  BYTE2))
                             (CL:IF COUNTP
                                 (CL:VALUES (CL:IF RAW
                                                CODE
                                                (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))
                                        0))
                     ELSEIF NOERROR
                     ELSE (AND COUNTP (CL:VALUES NIL 0)))
           ELSEIF NOERROR
             THEN (AND COUNTP (CL:VALUES NIL 0))
           ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2])

(\UTF16.BACKCHARFN
  [LAMBDA (STREAM COUNTP)                               (* ; "Edited 26-Jul-2020 13:05 by rmk:")

    (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT.")

    (* ;; "Common for big-ending and little-ending")

    (IF (NOT (\BACKFILEPTR STREAM))
        THEN (AND COUNTP 0)
      ELSEIF (\BACKFILEPTR STREAM)
        THEN (AND COUNTP 2)
      ELSE (AND COUNTP 1])
)

(RPAQ? EXTERNALEOL 'LF)
(DEFINEQ

(MAKE-UNICODE-FORMATS
  [LAMBDA (EXTERNALEOL)                                 (* ; "Edited  9-Aug-2020 08:40 by rmk:")

    (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.")

    (* ;; "The EXTERNALEOL specifies the EOLCONVENTION of the stream, particularly to produce output files with the desired convention.  On input the macro \CHECKEOLC (LLREAD) coerces only that coding to the internal EOL, which is a mistake.")

    (SETQ EXTERNALEOL (SELECTQ EXTERNALEOL
                          (LF LF.EOLC)
                          (CR CR.EOLC)
                          (CRLF CRLF.EOLC)
                          (SHOULDNT)))
    (\INSTALL.EXTERNALFORMAT :UTF16BE (CREATE EXTERNALFORMAT
                                             EOLVALID _ T
                                             EOL _ EXTERNALEOL
                                             INCCODEFN _ (FUNCTION UTF16BE.INCCODEFN)
                                             PEEKCCODEFN _ (FUNCTION UTF16BE.PEEKCCODEFN)
                                             BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN)
                                             FILEOUTCHARFN _ (FUNCTION UTF16BE.OUTCHARFN)))
    [\INSTALL.EXTERNALFORMAT :UTF16BE-RAW (CREATE EXTERNALFORMAT
                                                 EOLVALID _ T
                                                 EOL _ EXTERNALEOL
                                                 INCCODEFN _ [FUNCTION (LAMBDA (STREAM)
                                                                         (UTF16BE.INCCODEFN
                                                                          STREAM T]
                                                 PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR 
                                                                                        COUNTP)
                                                                           (UTF16BE.PEEKCCODEFN
                                                                            STREAM NOERROR COUNTP T]
                                                 BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN)
                                                 FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE)
                                                                             (UTF16BE.OUTCHARFN
                                                                              STREAM CHARCODE T]
    [\INSTALL.EXTERNALFORMAT :UTF8-RAW (CREATE EXTERNALFORMAT
                                              EOLVALID _ T
                                              EOL _ EXTERNALEOL
                                              INCCODEFN _ [FUNCTION (LAMBDA (STREAM COUNTP)
                                                                      (UTF8.INCCODEFN STREAM 
                                                                             COUNTP T]
                                              PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR COUNTP)
                                                                        (UTF8.PEEKCCODEFN STREAM
                                                                               NOERROR COUNTP T]
                                              BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN)
                                              FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE)
                                                                          (UTF8.OUTCHARFN STREAM
                                                                                 CHARCODE T]
    (\INSTALL.EXTERNALFORMAT :UTF8 (CREATE EXTERNALFORMAT
                                          EOLVALID _ T
                                          EOL _ EXTERNALEOL
                                          INCCODEFN _ (FUNCTION UTF8.INCCODEFN)
                                          PEEKCCODEFN _ (FUNCTION UTF8.PEEKCCODEFN)
                                          BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN)
                                          FILEOUTCHARFN _ (FUNCTION UTF8.OUTCHARFN])
)

(MAKE-UNICODE-FORMATS EXTERNALEOL)

(ADDTOVAR *DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8))
(DEFINEQ

(UNICODE.UNMAPPED
  [LAMBDA (CODE TRANSLATION-TABLE)                      (* ; "Edited 11-Aug-2020 20:23 by rmk:")

    (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODED has no fast mapping in TRANSLATION-TABLE.")

    (* ;; "We return an existing entry in the hash array of the table.  If CODE has not previously been seen, we allocate a new code in the forward unmapped hasharray and put the inverse in the backward array.")

    (LET ((FORWARD (CL:SVREF TRANSLATION-TABLE N-TRANSLATION-SEGMENTS))
          INVERSE NEXTCODE)
         (IF (GETHASH CODE (CAR FORWARD))
           ELSEIF (AND (ILEQ CODE (CADDR FORWARD))
                           (IGEQ CODE (CADDDR FORWARD)))
             THEN (ERROR "UNMAPPED CODE IS EITHER XCCS-UNUSED OR UNICODE-PRIVATE" CODE)
           ELSE (SETQ INVERSE (CL:SVREF TRANSLATION-TABLE (ADD1 N-TRANSLATION-SEGMENTS)))
                 (SETQ NEXTCODE (ADD (CADR INVERSE)
                                       1))
                 (CL:WHEN (IGREATERP NEXTCODE (CADDR INVERSE))
                        (ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES" CODE))
                 (PUTHASH CODE NEXTCODE (CAR FORWARD))
                 (PUTHASH NEXTCODE CODE (CAR INVERSE))
                 NEXTCODE])
)
(DEFINEQ

(XCCS-UTF8-AFTER-OPEN
  [LAMBDA (STREAM ACCESS PARAMETERS)                    (* ; "Edited 13-Aug-2020 11:54 by rmk:")

    (* ;; "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF8.")

    (CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM)))
                  [EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM)
                                          'EXTENSION]
                  (NOT (ASSOC 'EXTERNALFORMAT PARAMETERS)))
        (STREAMPROP STREAM 'EXTERNALFORMAT :UTF8))])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS UNICODE.TRANSLATE MACRO [OPENLAMBDA (CODE TRANSLATION-TABLE)
                                            (LET [(X (CL:SVREF TRANSLATION-TABLE (LRSH CODE 
                                                                                    TRANSLATION-SHIFT
                                                                                       ]
                                                 (COND
                                                    ((LISTP X)
                                                     (OR (CDR (FASSOC (LOGAND CODE TRANSLATION-SHIFT)
                                                                     X))
                                                         CODE))
                                                    [(AND X (CL:SVREF X (LOGAND CODE TRANSLATION-MASK
                                                                               ]
                                                    (T (UNICODE.UNMAPPED CODE TRANSLATION-TABLE])
)
)
(DEFINEQ

(XTOUCODE
  [LAMBDA (XCCSCODE)                                    (* ; "Edited  9-Aug-2020 09:04 by rmk:")
    (UNICODE.TRANSLATE XCCSCODE *XCCSTOUNICODE*])

(UTOXCODE
  [LAMBDA (UNICODE)                                     (* ; "Edited  9-Aug-2020 09:04 by rmk:")
    (UNICODE.TRANSLATE UNICODE *UNICODETOXCCS*])
)



(* ;; "Unicode mapping files")

(DEFINEQ

(READ-UNICODE-MAPPING-FILENAMES
  [LAMBDA (FILESPEC)                                  (* ; "Edited  5-Aug-2020 15:59 by kaplan")
                                                             (* ; 
                                                           "Edited  4-Aug-2020 17:31 by rmk:")
    (FOR F X CSI INSIDE FILESPEC
       COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT)
                                  T UNICODEDIRECTORIES)
                     ELSEIF [SETQ CSI (OR (SASSOC F XCCS-SET-NAMES)
                                              (FIND N IN XCCS-SET-NAMES
                                                 SUCHTHAT (EQ F (CADR N]
                       THEN (FINDFILE (PACKFILENAME 'BODY (CONCAT 'XCCS- (CAR CSI)
                                                                     '=
                                                                     (CADR CSI))
                                                 'EXTENSION
                                                 'TXT)
                                       T UNICODEDIRECTORIES)
                     ELSE F])

(READ-UNICODE-MAPPING
  [LAMBDA (FILESPEC NOPRINT NOERROR)                    (* ; "Edited 16-Aug-2020 16:46 by rmk:")

    (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format.  Comments prefixed by # and")

    (* ;; "               Column 1:  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")

    (FOR FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] IN (
                                                                     READ-UNICODE-MAPPING-FILENAMES
                                                                             FILESPEC)
       JOIN (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT :UTF8-RAW)
                       (BIND LINE START FIRST (CL:UNLESS 
                                                          (FILEPOS "Name:" STREAM NIL NIL NIL T)
                                                          (ERROR "NOT A UNICODE MAPPING FILE"
                                                                 (FULLNAME STREAM)))
                                                  (SETQ LINE (CL:READ-LINE STREAM NIL NIL))
                                                  (CL:UNLESS NOPRINT
                                                      (PRINTOUT T T "Unicode mapping:  "
                                                             (CL:STRING-TRIM " " LINE)
                                                             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 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])

(WRITE-UNICODE-MAPPING
  [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK)        (* ; "Edited 16-Aug-2020 16:56 by rmk:")

    (* ;; "Writes a symbol unicode mapping file.  Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.")

    (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.")

    (* ;; "The output lines are of the form x0XXX<tab>x0UUUU<tab>#  Unicode-char")

    (* ;; 
  "If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.")

    (* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.")

    (IF (AND (EQ INCLUDECHARSETS T)
                 (NULL FILE))
        THEN (IF MAPPING
                     THEN (FOR CSI F IN XCCS-SET-NAMES WHEN (SETQ F
                                                                             (WRITE-UNICODE-MAPPING
                                                                              MAPPING
                                                                              (CAR CSI)
                                                                              NIL T)) COLLECT
                                                                                      F)
                   ELSE (PRINTOUT T "THERE ARE NO MAPPINGS" T)
                         NIL)
      ELSE
      (LET
       (IMAPPING CSETINFO RANGES)
       (CL:MULTIPLE-VALUE-SETQ (IMAPPING CSETINFO RANGES)
              (WRITE-UNICODE-INCLUDED MAPPING INCLUDECHARSETS))
       (IF IMAPPING
           THEN (CL:WITH-OPEN-FILE
                     (STREAM (WRITE-UNICODE-MAPPING-FILENAME FILE CSETINFO RANGES)
                            :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :EXTERNAL-FORMAT :UTF8-RAW)
                     (WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES)
                     (SORT IMAPPING T)
                     (FOR M CSET LEFTC FIRSTRIGHTC CSI IN IMAPPING
                        DO (SETQ LEFTC (CAR M))
                              (SETQ FIRSTRIGHTC (CADR M))
                              (CL:UNLESS (EQ CSET (LRSH LEFTC 8))
                                  (SETQ CSET (LRSH LEFTC 8))
                                  (SETQ CSI (ASSOC CSET CSETINFO))
                                  (PRINTOUT STREAM T "#  " .P2 (CADR CSI)
                                         " "
                                         (CADDR CSI)
                                         T))
                              (PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4)
                                     %#
                                     (FOR RIGHTC IN (CDR M)
                                        DO (PRINTOUT NIL "	" "0x" (HEXSTRING RIGHTC 4)))
                                     "	#  "
                                     (SELECTC FIRSTRIGHTC
                                         (UNDEFINEDCODE 
                                                        (* ;; "FFFF")

                                                        "UNDEFINED")
                                         (MISSINGCODE 
                                                      (* ;; "FFFE")

                                                      "MISSING")
                                         (IF (ILESSP FIRSTRIGHTC 32)
                                             THEN        (* ; "Control chars")
                                                   [CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC
                                                                                 (CHARCODE @]
                                           ELSE (CHARACTER FIRSTRIGHTC)))
                                     T))
                     (FULLNAME STREAM))
         ELSEIF (NOT EMPTYOK)
           THEN (PRINTOUT T "THERE ARE NO MAPPINGS")
                 (CL:WHEN INCLUDECHARSETS
                     (PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS)
                            T))
                 NIL])

(WRITE-UNICODE-INCLUDED
  [LAMBDA (MAPPING INCLUDECHARSETS)                     (* ; "Edited  4-Aug-2020 17:47 by rmk:")

    (* ;; "CSETINFO is a list of (num string name) for each included character set.")

    (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING)

         (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings")

         [SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN 
                                                                                       XCCS-SET-NAMES
                                                                             COLLECT (CAR CSI)))
                         JOIN [SETQ KNOWN (OR (SASSOC C XCCS-SET-NAMES)
                                                  (FIND N IN XCCS-SET-NAMES
                                                     SUCHTHAT (EQ C (CADR N)))
                                                  (HELP "UNKNOWN CHARACTER SET" (OCTALSTRING C]
                               (IF (SETQ POS (STRPOS "-" (CAR KNOWN)))
                                   THEN (FOR I FROM (CL:PARSE-INTEGER (SUBSTRING
                                                                                   (CAR KNOWN)
                                                                                   1
                                                                                   (SUB1 POS))
                                                                       :RADIX 8)
                                               TO (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN)
                                                                               (ADD1 POS))
                                                             :RADIX 8)
                                               COLLECT (LIST I (OCTALSTRING I)
                                                                 (CADR KNOWN)))
                                 ELSE (CONS (CONS (CL:PARSE-INTEGER (CAR KNOWN)
                                                             :RADIX 8)
                                                      KNOWN]
         (SETQ IMAPPING (FOR M CSI IN MAPPING WHEN (SETQ CSI (ASSOC (LRSH (CAR M)
                                                                                      8)
                                                                                ICSETS))
                           COLLECT 

                                 (* ;; "The attested subset of INCLUDED")

                                 (CL:UNLESS (MEMB CSI CSETINFO)
                                        (PUSH CSETINFO CSI))
                                 M))

         (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges")

         (SETQ CSETINFO (SORT CSETINFO T))
         [SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO
                                                           COLLECT (CAR CSI)) WHILE CTAIL
                         COLLECT (SETQ START (CAR CTAIL))
                               (SETQ END START)
                               (CONS START (WHILE [AND (CDR CTAIL)
                                                           (EQ END (SUB1 (CADR CTAIL]
                                              COLLECT (SETQ CTAIL (CDR CTAIL))
                                                    (SETQ END (CAR CTAIL]

         (* ;; "Split out groups of less than 3.  But if a range exhaustively covers a known subset (like JIS), replace by the name")

         [SETQ RANGES (FOR R STR KNOWN LAST IN RANGES
                         JOIN (SETQ LAST (CAR (LAST R)))
                               (IF (EQ (CAR R)
                                           LAST)
                                   THEN (CONS (OCTALSTRING (CAR R)))
                                 ELSEIF (SETQ KNOWN (SASSOC (SETQ STR (CONCAT (OCTALSTRING
                                                                                   (CAR R))
                                                                                 "-"
                                                                                 (OCTALSTRING LAST)))
                                                               XCCS-SET-NAMES))
                                   THEN (CONS (CADR KNOWN))
                                 ELSEIF (CDDR R)
                                   THEN (CONS STR)
                                 ELSE (LIST (OCTALSTRING (CAR R))
                                                (OCTALSTRING LAST]
         (CL:VALUES IMAPPING CSETINFO RANGES])

(WRITE-UNICODE-MAPPING-HEADER
  [LAMBDA (STREAM CSETINFO RANGES)                      (* ; "Edited  4-Aug-2020 17:38 by rmk:")

    (* ;; "Writes the standard per-file header information")

    (FOR LINE IN UNICODE-MAPPING-HEADER
       DO (PRINTOUT STREAM "#" 2)
             (SELECTQ LINE
                 (XCCSCHARACTERSETS 
                      (PRINTOUT STREAM "        XCCS charset")
                      (IF (CDR CSETINFO)
                          THEN (PRINTOUT STREAM "s:" -4)
                                (FOR R IN RANGES DO (PRINTOUT STREAM R " "))
                                (TERPRI STREAM)
                        ELSE                             (* ; "Singleton")
                              (PRINTOUT STREAM ": " -4 (CADAR CSETINFO)
                                     " "
                                     (CADDAR CSETINFO)))
                      (TERPRI STREAM))
                 (DATE (PRINTOUT STREAM "        Date:" -13 (DATE (DATEFORMAT NO.TIME 
                                                                         NO.LEADING.SPACES))
                              T))
                 (PRINTOUT STREAM LINE T)))
    (TERPRI STREAM])

(WRITE-UNICODE-MAPPING-FILENAME
  [LAMBDA (FILE CSETINFO RANGES)                        (* ; "Edited  4-Aug-2020 19:34 by rmk:")
    (PACKFILENAME 'BODY [OR FILE (CONCATLIST
                                  (CONS 'XCCS- (IF (CDR CSETINFO)
                                                   THEN (FOR RTAIL R ON RANGES
                                                               JOIN (SETQ R (CAR RTAIL))
                                                                     (SETQ R
                                                                      (CL:IF (LISTP R)
                                                                          (LIST (CAR R)
                                                                                "-"
                                                                                (CDR R))
                                                                          (CONS R)))
                                                                     (CL:IF (CDR RTAIL)
                                                                            (NCONC1 R ","))
                                                                     R)
                                                 ELSE (LIST (CADAR CSETINFO)
                                                                "="
                                                                (CADDAR CSETINFO]
           'DIRECTORY
           (CAR UNICODEDIRECTORIES)
           'EXTENSION
           'TXT])
)

(RPAQQ XCCS-SET-NAMES
       (("0" LATIN)
        ("41" SYMBOLS1)
        ("42" SYMBOLS2)
        ("43" EXTENDED-LATIN)
        ("44" HIRAGANA)
        ("45" KATAKANA)
        ("46" GREEK)
        ("47" CYRILLIC)
        ("50" FORMS)
        ("60-172" JIS)
        ("340" ARABIC)
        ("341" HEBREW)
        ("342" IPA)
        ("343" HANGUL)
        ("344" GEORGIAN-ARMENIAN)
        ("356" SYMBOLS3)
        ("357" SYMBOLS4)
        ("360" LIGATURES)
        ("361" ACCENTED-LATIN)
        ("365" MORE-ARABIC)
        ("375" GRAPHIC-VARIANTS)))



(* ;; "Automate dumping of a documentation prefix")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQ MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16))

(RPAQ UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16))


(CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16))
       (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16)))
)
)

(RPAQQ UNICODE-MAPPING-HEADER
       ("" "        Name:             XCCS (XC-3-1-1-0) to Unicode" "        Unicode version:  3.0" 
           XCCSCHARACTERSETS "        Table version:    0.1" "        Table format:     Format A" 
           DATE "        Author:           Ron Kaplan <Ron.Kaplan@post.harvard.edu>" "" 
           "This file contains mappings from the Xerox Character Code Standard (version" 
           "XC1-3-3-0, 1987) into Unicode 3.0. standard codes.  That is the version of" 
           "XCCS corresponding to the fonts in the Medley system." "" 
           "The format of this file conforms to the format of the other Unicode-supplied" 
           "mapping files:" "   Three white-space (tab or spaces) separated columns:" 
           "     Column 1 is the XCCS code (as hex 0xXXXX)" 
           "     Column 2 is the corresponding Unicode (as hex 0xXXXX)" 
           "     Column 3 (after #) is a comment column. For convenience, it contains the" 
           "        Unicode character itself (since the Unicode character names" 
           "        are not available)" 
           "Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED" 
           "Unicode FFFE is used for XCCS codes that have not yet been filled in." 
           "(Column 3 = MISSING)" "" "This file is encoded in UTF8, so that the Unicode characters" 
           "are properly displayed in Column 3 and can be edited by standard" 
           "Unicode-enabled editors (e.g. Mac Textedit)." "" 
           "This file can also be read by the function" 
           "READ-UNICODE-MAPPING in the UNICODE Medley library package." "" 
           "The entries are in XCCS order and grouped by character sets.  In front of" 
           "the mappings, for convenience, there is a line with the octal XCCS" 
           "character set, after #." "" 
           "Note that a given XCCS code might map to codes in several different Unicode" 
           "positions, since there are repetitions in the Unicode standard." "" 
           "For more details, see the associated README.TXT file." "" 
           "Any comments or problems, contact <ron.kaplan@post.harvard.edu>"))

(RPAQ? UNICODEDIRECTORIES NIL)

(PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR")
                                       '/lispcore/unicode/xerox/))



(* ;; "Set up translation tables for UTF8 and UTFBE external formats")

(DEFINEQ

(MAKE-UNICODE-TRANSLATION-TABLES
  [LAMBDA (MAPPING LTORVAR RTOLVAR)                     (* ; "Edited 17-Aug-2020 08:46 by rmk:")

    (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to a Unicode mapping file.")

    (* ;; "This 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).")

    (* ;; "")

    (* ;; "We assume that the left-to-right mapping into Unicode is functional, so that each left code maps to a unique right (Unicode) code, because Unicode is presumably the most refined coding scheme.  But several Unicode codes may map to the same left code, for logically different codes that happen to have the same glyphs. In that case the heuristic is to map each %"from%" code to the lowest of the possible %"to%" codes. This means that round-trip reading/writing or writing/reading from one or both starting points may not always be lossless.")

    (* ;; " ")

    (* ;; " Each recoding array has 256 elements, one for each possible high-order byte of a character code.  An array entry is either NIL, a 256-array of codes indexed by low-order bytes, or an alist of (lower-order-bytes . codes).  The latter is used to save space for sparsely populated character sets.")

    (* ;; "")

    (* ;; "The element 256 of each array contains a hash table for characters that might be encountered in XCCS memory or Unicode files for which there is no mapping.  Element 257 contains the corresponding inverse unmapped hash-array, so that UNICODE.TRANSLATE can update them consistently.")

    (* ;; "")

    (* ;; "UNICODE.TRANSLATE assigns an unmapped Unicode character to a %"not used%" XCCS code position (from 5,0 to 40,FF, leaving other low not-used sets for other internal uses (TEDIT?).")

    (* ;; "")

    (* ;; 
  "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF")

    (* ;; "")

    (* ;; "For the convenience of not having to deal with the multiple values, if LTORVAR or RTOLVAR are given, they are set to the constructed arrays before return.")

    (* ;; "")

    (LET ((LTORARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS)
                            :INITIAL-ELEMENT NIL))
          (RTOLARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS)
                            :INITIAL-ELEMENT NIL)))

         (* ;; "The left-to-right direction (into Unicode).    We start by distributing the mappings into alists in arrays indexed by the higher-order (charaset set byte).  The second loop converts long alists into arrays.")

         [FOR M LEFTC RBASE RCODES IN MAPPING EACHTIME (SETQ RCODES (CDR M))
                                                            (SETQ RBASE (CAR RCODES))
            UNLESS (IGEQ RBASE MISSINGCODE) DO (SETQ LEFTC (CAR M)) 

                                                      (* ;; 
                                                    "(CDR RCODES) contains combiners on the base")

                                                      (CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK)
                                                                     (CL:IF (CDR RCODES)
                                                                         RCODES
                                                                         RBASE))
                                                             (CL:SVREF LTORARRAY (LRSH LEFTC 
                                                                                    TRANSLATION-SHIFT
                                                                                       ]
         (FOR I CSA FROM 0 TO (SUB1 N-TRANSLATION-SEGMENTS)
            WHEN (IGREATERP (LENGTH (CL:SVREF LTORARRAY I))
                            MAX-ALIST-LENGTH)
            DO 

                  (* ;; "Leave it alone if the alist is short")

                  (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
                  (FOR P IN (CL:SVREF LTORARRAY I)
                     DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P)
                                                          TRANSLATION-MASK))
                                   (CDR P)))
                  (CL:SETF (CL:SVREF LTORARRAY I)
                         CSA))

         (* ;; "")

         (* ;; "Now the right-to-left direction (from Unicode). Here we have to detect and compensate for ambiguity.")

         (FOR M LEFTC RBASE RCOMBINERS PREV IN MAPPING EACHTIME (SETQ RBASE (CADR M))
                                                                     (SETQ RCOMBINERS (CDDR M))
            UNLESS (OR (IGEQ RBASE MISSINGCODE)
                           RCOMBINERS) DO 

                                             (* ;; 
                                     "Have we already seen an explicit mapping from right to left?")

                                             (SETQ LEFTC (CAR M))
                                             [SETQ PREV (ASSOC (LOGAND RBASE TRANSLATION-MASK)
                                                               (CL:SVREF RTOLARRAY (LRSH RBASE 
                                                                                    TRANSLATION-SHIFT
                                                                                         ]
                                             (IF (NULL PREV)
                                                 THEN (CL:PUSH (CONS (LOGAND RBASE 
                                                                                TRANSLATION-MASK)
                                                                         LEFTC)
                                                                 (CL:SVREF RTOLARRAY (LRSH RBASE 
                                                                                    TRANSLATION-SHIFT
                                                                                           )))
                                               ELSEIF (IGREATERP (CDR PREV)
                                                                 LEFTC)
                                                 THEN (RPLACD PREV LEFTC)))
         (FOR I CSA FROM 0 TO (SUB1 N-TRANSLATION-SEGMENTS)
            WHEN (IGREATERP (LENGTH (CL:SVREF RTOLARRAY I))
                            MAX-ALIST-LENGTH)
            DO 

                  (* ;; "Long list, make an array")

                  (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
                  (FOR P IN (CL:SVREF RTOLARRAY I)
                     DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P)
                                                          TRANSLATION-MASK))
                                   (CDR P)))
                  (CL:SETF (CL:SVREF RTOLARRAY I)
                         CSA))

         (* ;; "")

         (* ;; "Allocate the hash arrays for future out-of-map codes.  We we have to keep track of the next available and last possible codes, as well as the first available, for error checking.")

         (CL:SETF (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS)
                (LIST (HASHARRAY 10)
                      (CHARCODE.DECODE "5,0")
                      (CHARCODE.DECODE "40,0")
                      (CHARCODE.DECODE "5,0")))
         (CL:SETF (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS)
                (LIST (HASHARRAY 10)
                      (CHARCODE.DECODE "E000")
                      (CHARCODE.DECODE "F8FF")
                      (CHARCODE.DECODE "E000")))

         (* ;; "Now put in the inverse unmapped hash arrays")

         (CL:SETF (CL:SVREF LTORARRAY (ADD1 N-TRANSLATION-SEGMENTS))
                (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS))
         (CL:SETF (CL:SVREF RTOLARRAY (ADD1 N-TRANSLATION-SEGMENTS))
                (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS))

         (* ;; "")

         (CL:WHEN LTORVAR (SETATOMVAL LTORVAR LTORARRAY))
         (CL:WHEN RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY))
         (CL:VALUES LTORARRAY RTOLARRAY])
)

(RPAQ? DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 
                                         ACCENTED-LATIN))
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(MAKE-UNICODE-TRANSLATION-TABLES (READ-UNICODE-MAPPING DEFAULT-XCCS-CHARSETS T)
       '*XCCSTOUNICODE*
       '*UNICODETOXCCS*)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*)
)
(DEFINEQ

(HEXSTRING
  [LAMBDA (N WIDTH)                                     (* ; "Edited 23-Jul-2020 08:28 by rmk:")
                                                             (* ; "Edited 20-Dec-93 17:51 by rmk:")

    (* ;; 
  "Converts positive numbers to Hex strings, padding on the right with 0 up to WIDTH if given.")

    (CL:UNLESS (FIXP N)
        (SETQ N (CHARCODE.DECODE N)))
    (LET [CHAR (STR (ALLOCSTRING [IMAX (OR WIDTH 0)
                                       (FOR I (LEFT _ N) FROM 0 UNTIL (EQ LEFT 0)
                                          DO (SETQ LEFT (LRSH LEFT 4))
                                          FINALLY (RETURN (MAX I 1]
                           (CHARCODE 0]
         (FOR I FROM -1 BY -1 UNTIL (EQ N 0)
            DO (SETQ CHAR (LOGAND N 15))
                  [RPLCHARCODE STR I (IF (ILESSP CHAR 10)
                                         THEN (+ CHAR (CHARCODE 0))
                                       ELSE (+ (- CHAR 10)
                                                   (CHARCODE A]
                  (SETQ N (LRSH N 4)))
         STR])

(UTF8HEXSTRING
  [LAMBDA (CHARCODE)                                    (* ; "Edited 10-Aug-2020 08:33 by rmk:")

    (* ;; "Utility to produces the UTF8 hexstring representing CODE")

    (HEXSTRING (IF (ILESSP CHARCODE 128)
                       THEN CHARCODE
                     ELSEIF (ILESSP CHARCODE 2048)
                       THEN                              (* ; "x800")
                             (LOGOR (LLSH (LOGOR (LLSH 3 6)
                                                 (LRSH CHARCODE 6))
                                          8)
                                    (LOGOR (LLSH 2 6)
                                           (LOADBYTE CHARCODE 0 6)))
                     ELSEIF (ILESSP CHARCODE 65536)
                       THEN                              (* ; "x10000")
                             (LOGOR (LLSH (LOGOR (LLSH 7 5)
                                                 (LRSH CHARCODE 12))
                                          16)
                                    (LLSH (LOGOR (LLSH 2 6)
                                                 (LOADBYTE CHARCODE 6 6))
                                          8)
                                    (LOGOR (LLSH 2 6)
                                           (LOADBYTE CHARCODE 0 6)))
                     ELSEIF (ILESSP CHARCODE 2097152)
                       THEN                              (* ; "x200000")
                             (LOGOR (LLSH (LOGOR (LLSH 15 4)
                                                 (LRSH CHARCODE 18))
                                          24)
                                    (LLSH (LOGOR (LLSH 2 6)
                                                 (LOADBYTE CHARCODE 12 6))
                                          16)
                                    (LLSH (LOGOR (LLSH 2 6)
                                                 (LOADBYTE CHARCODE 6 6))
                                          8)
                                    (LOGOR (LLSH 2 6)
                                           (LOADBYTE CHARCODE 0 6)))
                     ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE])

(NUTF8CODEBYTES
  [LAMBDA (N)                                           (* ; "Edited 10-Aug-2020 12:35 by rmk:")

    (* ;; "Returns the number of bytes needed to encode N in UTF8, ")

    (IF (ILESSP N 128)
        THEN 1
      ELSEIF (ILESSP N 2048)
        THEN                                             (* ; "x800")
              4
      ELSEIF (ILESSP N 65536)
        THEN                                             (* ; "x10000")
              3
      ELSEIF (ILESSP N 2097152)
        THEN                                             (* ; "x200000")
              2
      ELSE (SHOULDNT])

(NUTF8STRINGBYTES
  [LAMBDA (STRING RAWFLG)                               (* ; "Edited 10-Aug-2020 09:06 by rmk:")

    (* ;; "Returns the number of bytes it would take to represent STRING in UTF8, assuming it is an XCCS string unless RAWFLG. ")

    (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE STRING I))
       SUM (NUTF8CODEBYTES (CL:IF RAWFLG
                                       C
                                       (XTOUCODE C))])

(XTOUSTRING
  [LAMBDA (XCCSSTRING RAWFLG)                           (* ; "Edited 10-Aug-2020 21:42 by rmk:")

    (* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XCCSSTRING.  Applies the XCCSTOUNICODE translation unless RAWFLG.  ")

    (* ;; "The resulting string will not be readable inside Medley.")

    (LET [(USTR (ALLOCSTRING (NUTF8STRINGBYTES XCCSSTRING RAWFLG]
         (FOR I CHARCODE (SINDEX _ 0) FROM 1 WHILE (SETQ CHARCODE (NTHCHARCODE XCCSSTRING
                                                                                     I))
            DO (CL:UNLESS RAWFLG
                       (SETQ CHARCODE (XTOUCODE CHARCODE)))
                  (IF (ILESSP CHARCODE 128)
                      THEN (RPLCHARCODE USTR (ADD SINDEX 1)
                                      CHARCODE)
                    ELSEIF (ILESSP CHARCODE 2048)
                      THEN                               (* ; "x800")
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 3 6)
                                          (LRSH CHARCODE 6)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 0 6)))
                    ELSEIF (ILESSP CHARCODE 65536)
                      THEN                               (* ; "x10000")
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 7 5)
                                          (LRSH CHARCODE 12)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 6 6)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 0 6)))
                    ELSEIF (ILESSP CHARCODE 2097152)
                      THEN                               (* ; "x200000")
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 15 4)
                                          (LRSH CHARCODE 18)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 12 6)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 6 6)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 0 6)))
                    ELSE (SHOULDNT)))
         USTR])

(XCCSSTRING
  [LAMBDA (CODE)                                        (* ; "Edited 13-Aug-2020 12:16 by rmk:")

    (* ;; "Returns XCCS character representation of string %"cset,char%"")

    (CL:UNLESS (FIXP CODE)
        (SETQ CODE (CHCON1 CODE)))
    (CONCAT (OCTALSTRING (LRSH CODE 8))
           ","
           (OCTALSTRING (LOGAND CODE 255])
)
(DEFINEQ

(SHOWCHARS
  [LAMBDA (FROMCHAR TOCHAR FONT)                        (* ; "Edited  1-Aug-2020 09:27 by rmk:")
    (RESETFORM (DSPFONT (OR FONT '(CLASSIC 12))
                      T)
           (CL:WHEN (AND (SMALLP FROMCHAR)
                         (NOT TOCHAR))

               (* ;; 
    "If a small number, assume it's an octal (in decimal) character set, no need for string quotes")

               (SETQ TOCHAR (CONCAT FROMCHAR "," 376))
               (SETQ FROMCHAR (CONCAT FROMCHAR "," 41)))
           (CL:UNLESS (SMALLP FROMCHAR)
               (SETQ FROMCHAR (CHARCODE.DECODE FROMCHAR)))
           (CL:UNLESS (SMALLP TOCHAR)
               (SETQ TOCHAR (CL:IF TOCHAR
                                (CHARCODE.DECODE TOCHAR)
                                FROMCHAR)))
           (FOR C FROM FROMCHAR TO TOCHAR UNLESS (AND (IGEQ (LOGAND C 255)
                                                                            127)
                                                                      (ILEQ (LOGAND C 255)
                                                                            (PLUS 128 33)))
              DO (PRINTOUT T .P2 (CONCAT (OCTALSTRING (LRSH CODE 8))
                                            ","
                                            (OCTALSTRING (LOGAND CODE 255)))
                            10
                            (CHARACTER C)
                            T])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ LF.EOLC 1)

(RPAQQ CR.EOLC 0)

(RPAQQ CRLF.EOLC 2)


(CONSTANTS (LF.EOLC 1)
       (CR.EOLC 0)
       (CRLF.EOLC 2))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ TRANSLATION-SEGMENT-SIZE 128)

(RPAQQ MAX-ALIST-LENGTH 10)

(RPAQ N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE))

(RPAQ TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE)))

(RPAQ TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE))


(CONSTANTS (TRANSLATION-SEGMENT-SIZE 128)
       (MAX-ALIST-LENGTH 10)
       (N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE))
       (TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE)))
       (TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE)))
)


(EVAL (SYSRECLOOK1 'EXTERNALFORMAT))

(EVAL (SYSRECLOOK1 'STREAM))
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4144 16328 (UTF8.OUTCHARFN 4154 . 6438) (UTF8.INCCODEFN 6440 . 10539) (UTF8.PEEKCCODEFN
 10541 . 15819) (\UTF8.BACKCHARFN 15821 . 16326)) (16329 19651 (UTF16BE.OUTCHARFN 16339 . 17072) (
UTF16BE.INCCODEFN 17074 . 17951) (UTF16BE.PEEKCCODEFN 17953 . 19208) (\UTF16.BACKCHARFN 19210 . 19649)
) (19681 23821 (MAKE-UNICODE-FORMATS 19691 . 23819)) (23918 25224 (UNICODE.UNMAPPED 23928 . 25222)) (
25225 25761 (XCCS-UTF8-AFTER-OPEN 25235 . 25759)) (26831 27180 (XTOUCODE 26841 . 27009) (UTOXCODE 
27011 . 27178)) (27220 43402 (READ-UNICODE-MAPPING-FILENAMES 27230 . 28392) (READ-UNICODE-MAPPING 
28394 . 31691) (WRITE-UNICODE-MAPPING 31693 . 35910) (WRITE-UNICODE-INCLUDED 35912 . 40634) (
WRITE-UNICODE-MAPPING-HEADER 40636 . 41868) (WRITE-UNICODE-MAPPING-FILENAME 41870 . 43400)) (46748 
55117 (MAKE-UNICODE-TRANSLATION-TABLES 46758 . 55115)) (55532 63436 (HEXSTRING 55542 . 56703) (
UTF8HEXSTRING 56705 . 58910) (NUTF8CODEBYTES 58912 . 59575) (NUTF8STRINGBYTES 59577 . 60058) (
XTOUSTRING 60060 . 63071) (XCCSSTRING 63073 . 63434)) (63437 64906 (SHOWCHARS 63447 . 64904)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "29-Nov-2020 10:50:18" {DSK}<home>larry>ilisp>medley>library>UNICODE.;168 65700  

      changes to%:  (VARS UNICODECOMS)

      previous date%: "17-Aug-2020 08:48:36" {DSK}<home>larry>ilisp>medley>library>UNICODE.;167)


(PRETTYCOMPRINT UNICODECOMS)

(RPAQQ UNICODECOMS
       [(COMS 
              (* ;; "External formats")

              (FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCHARFN)
              (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCHARFN)
              (INITVARS (EXTERNALEOL 'LF))
              (FNS MAKE-UNICODE-FORMATS)
              (P (MAKE-UNICODE-FORMATS EXTERNALEOL))
              (ADDVARS (*DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8)))
              (FNS UNICODE.UNMAPPED)
              (FNS XCCS-UTF8-AFTER-OPEN)
              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE))
              (FNS XTOUCODE UTOXCODE))
        [COMS 
              (* ;; "Unicode mapping files")

              (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING 
                   WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME
                   )
              (VARS XCCS-SET-NAMES)
              
              (* ;; "Automate dumping of a documentation prefix")

              [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" 
                                                                              :RADIX 16))
                                                      (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX
                                                                            16]
              (VARS UNICODE-MAPPING-HEADER)
              (INITVARS (UNICODEDIRECTORIES NIL))
              (P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR")
                                                    '/unicode/xerox/]
        (COMS 
              (* ;; "Set up translation tables for UTF8 and UTFBE external formats")

              (FNS MAKE-UNICODE-TRANSLATION-TABLES)
              [INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS 
                                                       SYMBOLS3 SYMBOLS4 ACCENTED-LATIN]
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES (
                                                                                 READ-UNICODE-MAPPING
                                                                                   
                                                                                DEFAULT-XCCS-CHARSETS
                                                                                   T)
                                                        '*XCCSTOUNICODE*
                                                        '*UNICODETOXCCS*]
              (GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*))
        (FNS HEXSTRING UTF8HEXSTRING NUTF8CODEBYTES NUTF8STRINGBYTES XTOUSTRING XCCSSTRING)
        (FNS SHOWCHARS)
        (DECLARE%: EVAL@COMPILE DONTCOPY 

               (* ;; "This is taken from FILEIO")

               (CONSTANTS (LF.EOLC 1)
                      (CR.EOLC 0)
                      (CRLF.EOLC 2))
               
               (* ;; "These control the layout of the translation tables.  Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter")

               (CONSTANTS (TRANSLATION-SEGMENT-SIZE 128)
                      (MAX-ALIST-LENGTH 10)
                      (N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE))
                      (TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE)))
                      (TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE)))
               (P (EVAL (SYSRECLOOK1 'EXTERNALFORMAT))
                  (EVAL (SYSRECLOOK1 'STREAM])



(* ;; "External formats")

(DEFINEQ

(UTF8.OUTCHARFN
  [LAMBDA (STREAM CHARCODE RAW)                         (* ; "Edited 17-Aug-2020 08:45 by rmk:")
                                                            (* ; "Edited 30-Jan-2020 23:08 by rmk:")

    (* ;; "PRINT UTF8 sequence for CHARCODE.  Do not do XCCS to Unicode translation of RAW.")

    (CHANGE (FETCH (STREAM CHARPOSITION) OF STREAM)
           (CL:IF (EQ CHARCODE (CHARCODE EOL))
               0
               (IPLUS DATUM 1)))                             (* ; "Avoid overflow")
    (FOR C INSIDE (CL:IF RAW
                              CHARCODE
                              (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*))
       DO (IF (ILESSP C 128)
                  THEN (\BOUT STREAM C)
                ELSEIF (ILESSP C 2048)
                  THEN                                   (* ; "x800")
                        (\BOUT STREAM (LOGOR (LLSH 3 6)
                                             (LRSH C 6)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 0 6)))
                ELSEIF (ILESSP C 65536)
                  THEN                                   (* ; "x10000")
                        (\BOUT STREAM (LOGOR (LLSH 7 5)
                                             (LRSH C 12)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 6 6)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 0 6)))
                ELSEIF (ILESSP C 2097152)
                  THEN                                   (* ; "x200000")
                        (\BOUT STREAM (LOGOR (LLSH 15 4)
                                             (LRSH C 18)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 12 6)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 6 6)))
                        (\BOUT STREAM (LOGOR (LLSH 2 6)
                                             (LOADBYTE C 0 6)))
                ELSE (ERROR "CHARCODE too big for UTF8" C])

(UTF8.INCCODEFN
  [LAMBDA (STREAM COUNTP RAW)                           (* ; "Edited  6-Aug-2020 17:13 by rmk:")

    (* ;; "Do not do UNICODE to XCSS translation if RAW.")

    (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error")

    (LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT 1))
         (SETQ BYTE1 (\BIN STREAM))

         (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1")

         (CL:WHEN (SMALLP BYTE1)
             [SETQ CODE (IF (ILESSP BYTE1 128)
                            THEN 

                                  (* ;; "Test first:  Ascii is the common case")

                                  BYTE1
                          ELSEIF (IGEQ BYTE1 (LLSH 15 4))
                            THEN                         (* ; "4 bytes")
                                  (SETQ BYTE2 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE2))
                                               (ILESSP BYTE2 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                                  (SETQ BYTE3 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE3))
                                               (ILESSP BYTE3 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
                                  (SETQ BYTE4 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE4))
                                               (ILESSP BYTE4 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4)))
                                  (SETQ COUNT 4)
                                  (LOGOR (LLSH (LOADBYTE BYTE1 0 3)
                                               18)
                                         (LLSH (LOADBYTE BYTE2 0 6)
                                               12)
                                         (LLSH (LOADBYTE BYTE3 0 6)
                                               6)
                                         (LOADBYTE BYTE4 0 6))
                          ELSEIF (IGEQ BYTE1 (LLSH 7 5))
                            THEN                         (* ; "3 bytes")
                                  (SETQ BYTE2 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE2))
                                               (ILESSP BYTE2 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                                  (SETQ BYTE3 (\BIN STREAM))
                                  (CL:WHEN (OR (NOT (SMALLP BYTE3))
                                               (ILESSP BYTE3 128))
                                      (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
                                  (SETQ COUNT 3)
                                  (LOGOR (LLSH (LOADBYTE BYTE1 0 4)
                                               12)
                                         (LLSH (LOADBYTE BYTE2 0 6)
                                               6)
                                         (LOADBYTE BYTE3 0 6))
                          ELSE                           (* ; "Must be 2 bytes")
                                (SETQ COUNT 2)
                                (SETQ BYTE2 (\BIN STREAM))
                                (CL:WHEN (OR (NOT (SMALLP BYTE2))
                                             (ILESSP BYTE2 128))
                                    (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                                (LOGOR (LLSH (LOADBYTE BYTE1 0 5)
                                             6)
                                       (LOADBYTE BYTE2 0 6])
         (CL:UNLESS (OR RAW (NOT (SMALLP CODE)))
             (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)))
         (CL:IF COUNTP
             (CL:VALUES CODE COUNT)
             CODE)])

(UTF8.PEEKCCODEFN
  [LAMBDA (STREAM NOERROR COUNTP RAW)                   (* ; "Edited  6-Aug-2020 17:12 by rmk:")

    (* ;; "Modeled this after \EUCPEEK on LLREAD.  In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0.  Returns NIL if NOERROR and either invalid UTF8 or end of file.")

    (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.")

    (* ;; "Do not do UNICODE to XCCS translation if RAW")

    (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE)
          (SETQ BYTE1 (\PEEKBIN STREAM NOERROR))

     (* ;; "Distinguish on header bytex")

          (CL:UNLESS BYTE1
              (RETURN (AND COUNTP (CL:VALUES NIL 0))))
          [IF (ILESSP BYTE1 128)
              THEN 

                    (* ;; 
                  "Test first:  Ascii is the common case.  No need to back up, since we peeked.")

                    (SETQ CODE BYTE1)
            ELSEIF (IGEQ BYTE1 (LLSH 15 4))
              THEN                                       (* ; "4 bytes")
                    (\BIN STREAM)
                    (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
                                    (IGEQ BYTE2 128))
                        (\BACKFILEPTR STREAM)
                        (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                        (RETURN (IF COUNTP
                                    THEN (CL:VALUES CODE 0)
                                  ELSE CODE)))
                    (\BIN STREAM)
                    (CL:UNLESS (AND (SETQ BYTE3 (\PEEKBIN STREAM NOERROR))
                                    (IGEQ BYTE3 128))
                        (\BACKFILEPTR STREAM)
                        (\BACKFILEPTR STREAM)
                        (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
                        (RETURN (IF COUNTP
                                    THEN (CL:VALUES CODE 0)
                                  ELSE CODE)))
                    (\BIN STREAM)
                    (SETQ BYTE4 (\PEEKBIN STREAM NOERROR))   (* ; 
                                                           "PEEK the last, no need to back it up")
                    (\BACKFILEPTR STREAM)
                    (\BACKFILEPTR STREAM)
                    (\BACKFILEPTR STREAM)
                    (IF (AND BYTE4 (IGEQ BYTE4 128))
                        THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 3)
                                                         18)
                                                   (LLSH (LOADBYTE BYTE2 0 6)
                                                         12)
                                                   (LLSH (LOADBYTE BYTE3 0 6)
                                                         6)
                                                   (LOADBYTE BYTE4 0 6)))
                      ELSEIF NOERROR
                      ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4)))
            ELSEIF (IGEQ BYTE1 (LLSH 7 5))
              THEN                                       (* ; "3 bytes")
                    (\BIN STREAM)
                    (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
                                    (IGEQ BYTE2 128))
                        (\BACKFILEPTR STREAM)
                        (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
                        (RETURN (IF COUNTP
                                    THEN (CL:VALUES CODE 0)
                                  ELSE CODE)))
                    (\BIN STREAM)
                    (SETQ BYTE3 (\PEEKBIN STREAM NOERROR))
                    (\BACKFILEPTR STREAM)
                    (\BACKFILEPTR STREAM)
                    (IF (AND BYTE3 (IGEQ BYTE3 128))
                        THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 4)
                                                         12)
                                                   (LLSH (LOADBYTE BYTE2 0 6)
                                                         6)
                                                   (LOADBYTE BYTE3 0 6)))
                      ELSEIF NOERROR
                      ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
            ELSE                                         (* ; "Must be 2 bytes")
                  (\BIN STREAM)
                  (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
                  (\BACKFILEPTR STREAM)
                  (IF (AND BYTE2 (IGEQ BYTE2 128))
                      THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5)
                                                       6)
                                                 (LOADBYTE BYTE2 0 6)))
                    ELSEIF NOERROR
                    ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2]
          (CL:WHEN (AND CODE (NOT RAW))
              (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)))
          (RETURN (IF COUNTP
                      THEN (CL:VALUES CODE 0)
                    ELSE CODE])

(\UTF8.BACKCHARFN
  [LAMBDA (STREAM COUNTP)                               (* ; "Edited 26-Jul-2020 10:41 by rmk:")

    (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT")

    (BIND (C _ 0) WHILE (CL:WHEN (\BACKFILEPTR STREAM)
                                    (ADD C 1)
                                    (EQ 2 (LRSH (\PEEKBIN STREAM)
                                                6))) REPEATUNTIL (EQ C 4)
       FINALLY (RETURN (AND COUNTP C])
)
(DEFINEQ

(UTF16BE.OUTCHARFN
  [LAMBDA (STREAM CHARCODE RAW)                         (* ; "Edited 17-Aug-2020 08:48 by rmk:")
                                                            (* ; "Edited 30-Jan-2020 23:08 by rmk:")

    (* ;; "PRINT UTF16 sequence for CHARCODE.  Do not do XCCS to UNICODE translation if RAW.")

    (CHANGE (FETCH (STREAM CHARPOSITION) OF STREAM)
           (CL:IF (EQ CHARCODE (CHARCODE EOL))
               0
               (IPLUS DATUM 1)))
    (FOR C INSIDE (CL:IF RAW
                              CHARCODE
                              (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*))
       DO (\BOUT STREAM (LRSH C 8))
             (\BOUT STREAM (LOGAND C 255])

(UTF16BE.INCCODEFN
  [LAMBDA (STREAM COUNTP RAW)                           (* ; "Edited  6-Aug-2020 17:48 by rmk:")

    (* ;; 
  "Do not do UNICODE to XCCS translation if RAW.  Test for SMALLPin case of funky EOF behavior")

    (LET (CODE BYTE1 BYTE2 COUNT)
         (IF [AND (SMALLP (SETQ BYTE1 (\BIN STREAM)))
                      (SMALLP (SETQ BYTE2 (\BIN STREAM]
             THEN (SETQ COUNT 2)
                   (SETQ CODE (LOGOR (LLSH (\BIN STREAM)
                                           8)
                                     (\BIN STREAM)))
                   (CL:UNLESS RAW
                       (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)))
                   (CL:IF COUNTP
                       (CL:VALUES CODE COUNT)
                       CODE)
           ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM])

(UTF16BE.PEEKCCODEFN
  [LAMBDA (STREAM NOERROR COUNTP RAW)                   (* ; "Edited 30-Jul-2020 14:06 by rmk:")

    (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.")

    (* ;; "Do not do UNICODE to XCCS translation if RAW")

    (LET (BYTE1 BYTE2 CODE)
         (SETQ BYTE1 (\PEEKBIN STREAM NOERROR))
         (IF BYTE1
             THEN (\BIN STREAM)
                   (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
                   (\BACKFILEPTR STREAM)
                   (IF BYTE2
                       THEN (SETQ CODE (LOGOR (LLSH BYTE1 8)
                                                  BYTE2))
                             (CL:IF COUNTP
                                 (CL:VALUES (CL:IF RAW
                                                CODE
                                                (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))
                                        0))
                     ELSEIF NOERROR
                     ELSE (AND COUNTP (CL:VALUES NIL 0)))
           ELSEIF NOERROR
             THEN (AND COUNTP (CL:VALUES NIL 0))
           ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2])

(\UTF16.BACKCHARFN
  [LAMBDA (STREAM COUNTP)                               (* ; "Edited 26-Jul-2020 13:05 by rmk:")

    (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT.")

    (* ;; "Common for big-ending and little-ending")

    (IF (NOT (\BACKFILEPTR STREAM))
        THEN (AND COUNTP 0)
      ELSEIF (\BACKFILEPTR STREAM)
        THEN (AND COUNTP 2)
      ELSE (AND COUNTP 1])
)

(RPAQ? EXTERNALEOL 'LF)
(DEFINEQ

(MAKE-UNICODE-FORMATS
  [LAMBDA (EXTERNALEOL)                                 (* ; "Edited  9-Aug-2020 08:40 by rmk:")

    (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.")

    (* ;; "The EXTERNALEOL specifies the EOLCONVENTION of the stream, particularly to produce output files with the desired convention.  On input the macro \CHECKEOLC (LLREAD) coerces only that coding to the internal EOL, which is a mistake.")

    (SETQ EXTERNALEOL (SELECTQ EXTERNALEOL
                          (LF LF.EOLC)
                          (CR CR.EOLC)
                          (CRLF CRLF.EOLC)
                          (SHOULDNT)))
    (\INSTALL.EXTERNALFORMAT :UTF16BE (CREATE EXTERNALFORMAT
                                             EOLVALID _ T
                                             EOL _ EXTERNALEOL
                                             INCCODEFN _ (FUNCTION UTF16BE.INCCODEFN)
                                             PEEKCCODEFN _ (FUNCTION UTF16BE.PEEKCCODEFN)
                                             BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN)
                                             FILEOUTCHARFN _ (FUNCTION UTF16BE.OUTCHARFN)))
    [\INSTALL.EXTERNALFORMAT :UTF16BE-RAW (CREATE EXTERNALFORMAT
                                                 EOLVALID _ T
                                                 EOL _ EXTERNALEOL
                                                 INCCODEFN _ [FUNCTION (LAMBDA (STREAM)
                                                                         (UTF16BE.INCCODEFN
                                                                          STREAM T]
                                                 PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR 
                                                                                        COUNTP)
                                                                           (UTF16BE.PEEKCCODEFN
                                                                            STREAM NOERROR COUNTP T]
                                                 BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN)
                                                 FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE)
                                                                             (UTF16BE.OUTCHARFN
                                                                              STREAM CHARCODE T]
    [\INSTALL.EXTERNALFORMAT :UTF8-RAW (CREATE EXTERNALFORMAT
                                              EOLVALID _ T
                                              EOL _ EXTERNALEOL
                                              INCCODEFN _ [FUNCTION (LAMBDA (STREAM COUNTP)
                                                                      (UTF8.INCCODEFN STREAM 
                                                                             COUNTP T]
                                              PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR COUNTP)
                                                                        (UTF8.PEEKCCODEFN STREAM
                                                                               NOERROR COUNTP T]
                                              BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN)
                                              FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE)
                                                                          (UTF8.OUTCHARFN STREAM
                                                                                 CHARCODE T]
    (\INSTALL.EXTERNALFORMAT :UTF8 (CREATE EXTERNALFORMAT
                                          EOLVALID _ T
                                          EOL _ EXTERNALEOL
                                          INCCODEFN _ (FUNCTION UTF8.INCCODEFN)
                                          PEEKCCODEFN _ (FUNCTION UTF8.PEEKCCODEFN)
                                          BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN)
                                          FILEOUTCHARFN _ (FUNCTION UTF8.OUTCHARFN])
)

(MAKE-UNICODE-FORMATS EXTERNALEOL)

(ADDTOVAR *DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8))
(DEFINEQ

(UNICODE.UNMAPPED
  [LAMBDA (CODE TRANSLATION-TABLE)                      (* ; "Edited 11-Aug-2020 20:23 by rmk:")

    (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODED has no fast mapping in TRANSLATION-TABLE.")

    (* ;; "We return an existing entry in the hash array of the table.  If CODE has not previously been seen, we allocate a new code in the forward unmapped hasharray and put the inverse in the backward array.")

    (LET ((FORWARD (CL:SVREF TRANSLATION-TABLE N-TRANSLATION-SEGMENTS))
          INVERSE NEXTCODE)
         (IF (GETHASH CODE (CAR FORWARD))
           ELSEIF (AND (ILEQ CODE (CADDR FORWARD))
                           (IGEQ CODE (CADDDR FORWARD)))
             THEN (ERROR "UNMAPPED CODE IS EITHER XCCS-UNUSED OR UNICODE-PRIVATE" CODE)
           ELSE (SETQ INVERSE (CL:SVREF TRANSLATION-TABLE (ADD1 N-TRANSLATION-SEGMENTS)))
                 (SETQ NEXTCODE (ADD (CADR INVERSE)
                                       1))
                 (CL:WHEN (IGREATERP NEXTCODE (CADDR INVERSE))
                        (ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES" CODE))
                 (PUTHASH CODE NEXTCODE (CAR FORWARD))
                 (PUTHASH NEXTCODE CODE (CAR INVERSE))
                 NEXTCODE])
)
(DEFINEQ

(XCCS-UTF8-AFTER-OPEN
  [LAMBDA (STREAM ACCESS PARAMETERS)                    (* ; "Edited 13-Aug-2020 11:54 by rmk:")

    (* ;; "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF8.")

    (CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM)))
                  [EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM)
                                          'EXTENSION]
                  (NOT (ASSOC 'EXTERNALFORMAT PARAMETERS)))
        (STREAMPROP STREAM 'EXTERNALFORMAT :UTF8))])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS UNICODE.TRANSLATE MACRO [OPENLAMBDA (CODE TRANSLATION-TABLE)
                                            (LET [(X (CL:SVREF TRANSLATION-TABLE (LRSH CODE 
                                                                                    TRANSLATION-SHIFT
                                                                                       ]
                                                 (COND
                                                    ((LISTP X)
                                                     (OR (CDR (FASSOC (LOGAND CODE TRANSLATION-SHIFT)
                                                                     X))
                                                         CODE))
                                                    [(AND X (CL:SVREF X (LOGAND CODE TRANSLATION-MASK
                                                                               ]
                                                    (T (UNICODE.UNMAPPED CODE TRANSLATION-TABLE])
)
)
(DEFINEQ

(XTOUCODE
  [LAMBDA (XCCSCODE)                                    (* ; "Edited  9-Aug-2020 09:04 by rmk:")
    (UNICODE.TRANSLATE XCCSCODE *XCCSTOUNICODE*])

(UTOXCODE
  [LAMBDA (UNICODE)                                     (* ; "Edited  9-Aug-2020 09:04 by rmk:")
    (UNICODE.TRANSLATE UNICODE *UNICODETOXCCS*])
)



(* ;; "Unicode mapping files")

(DEFINEQ

(READ-UNICODE-MAPPING-FILENAMES
  [LAMBDA (FILESPEC)                                  (* ; "Edited  5-Aug-2020 15:59 by kaplan")
                                                             (* ; 
                                                           "Edited  4-Aug-2020 17:31 by rmk:")
    (FOR F X CSI INSIDE FILESPEC
       COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT)
                                  T UNICODEDIRECTORIES)
                     ELSEIF [SETQ CSI (OR (SASSOC F XCCS-SET-NAMES)
                                              (FIND N IN XCCS-SET-NAMES
                                                 SUCHTHAT (EQ F (CADR N]
                       THEN (FINDFILE (PACKFILENAME 'BODY (CONCAT 'XCCS- (CAR CSI)
                                                                     '=
                                                                     (CADR CSI))
                                                 'EXTENSION
                                                 'TXT)
                                       T UNICODEDIRECTORIES)
                     ELSE F])

(READ-UNICODE-MAPPING
  [LAMBDA (FILESPEC NOPRINT NOERROR)                    (* ; "Edited 16-Aug-2020 16:46 by rmk:")

    (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format.  Comments prefixed by # and")

    (* ;; "               Column 1:  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")

    (FOR FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] IN (
                                                                     READ-UNICODE-MAPPING-FILENAMES
                                                                             FILESPEC)
       JOIN (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT :UTF8-RAW)
                       (BIND LINE START FIRST (CL:UNLESS 
                                                          (FILEPOS "Name:" STREAM NIL NIL NIL T)
                                                          (ERROR "NOT A UNICODE MAPPING FILE"
                                                                 (FULLNAME STREAM)))
                                                  (SETQ LINE (CL:READ-LINE STREAM NIL NIL))
                                                  (CL:UNLESS NOPRINT
                                                      (PRINTOUT T T "Unicode mapping:  "
                                                             (CL:STRING-TRIM " " LINE)
                                                             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 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])

(WRITE-UNICODE-MAPPING
  [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK)        (* ; "Edited 16-Aug-2020 16:56 by rmk:")

    (* ;; "Writes a symbol unicode mapping file.  Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.")

    (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.")

    (* ;; "The output lines are of the form x0XXX<tab>x0UUUU<tab>#  Unicode-char")

    (* ;; 
  "If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.")

    (* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.")

    (IF (AND (EQ INCLUDECHARSETS T)
                 (NULL FILE))
        THEN (IF MAPPING
                     THEN (FOR CSI F IN XCCS-SET-NAMES WHEN (SETQ F
                                                                             (WRITE-UNICODE-MAPPING
                                                                              MAPPING
                                                                              (CAR CSI)
                                                                              NIL T)) COLLECT
                                                                                      F)
                   ELSE (PRINTOUT T "THERE ARE NO MAPPINGS" T)
                         NIL)
      ELSE
      (LET
       (IMAPPING CSETINFO RANGES)
       (CL:MULTIPLE-VALUE-SETQ (IMAPPING CSETINFO RANGES)
              (WRITE-UNICODE-INCLUDED MAPPING INCLUDECHARSETS))
       (IF IMAPPING
           THEN (CL:WITH-OPEN-FILE
                     (STREAM (WRITE-UNICODE-MAPPING-FILENAME FILE CSETINFO RANGES)
                            :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :EXTERNAL-FORMAT :UTF8-RAW)
                     (WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES)
                     (SORT IMAPPING T)
                     (FOR M CSET LEFTC FIRSTRIGHTC CSI IN IMAPPING
                        DO (SETQ LEFTC (CAR M))
                              (SETQ FIRSTRIGHTC (CADR M))
                              (CL:UNLESS (EQ CSET (LRSH LEFTC 8))
                                  (SETQ CSET (LRSH LEFTC 8))
                                  (SETQ CSI (ASSOC CSET CSETINFO))
                                  (PRINTOUT STREAM T "#  " .P2 (CADR CSI)
                                         " "
                                         (CADDR CSI)
                                         T))
                              (PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4)
                                     %#
                                     (FOR RIGHTC IN (CDR M)
                                        DO (PRINTOUT NIL "	" "0x" (HEXSTRING RIGHTC 4)))
                                     "	#  "
                                     (SELECTC FIRSTRIGHTC
                                         (UNDEFINEDCODE 
                                                        (* ;; "FFFF")

                                                        "UNDEFINED")
                                         (MISSINGCODE 
                                                      (* ;; "FFFE")

                                                      "MISSING")
                                         (IF (ILESSP FIRSTRIGHTC 32)
                                             THEN        (* ; "Control chars")
                                                   [CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC
                                                                                 (CHARCODE @]
                                           ELSE (CHARACTER FIRSTRIGHTC)))
                                     T))
                     (FULLNAME STREAM))
         ELSEIF (NOT EMPTYOK)
           THEN (PRINTOUT T "THERE ARE NO MAPPINGS")
                 (CL:WHEN INCLUDECHARSETS
                     (PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS)
                            T))
                 NIL])

(WRITE-UNICODE-INCLUDED
  [LAMBDA (MAPPING INCLUDECHARSETS)                     (* ; "Edited  4-Aug-2020 17:47 by rmk:")

    (* ;; "CSETINFO is a list of (num string name) for each included character set.")

    (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING)

         (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings")

         [SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN 
                                                                                       XCCS-SET-NAMES
                                                                             COLLECT (CAR CSI)))
                         JOIN [SETQ KNOWN (OR (SASSOC C XCCS-SET-NAMES)
                                                  (FIND N IN XCCS-SET-NAMES
                                                     SUCHTHAT (EQ C (CADR N)))
                                                  (HELP "UNKNOWN CHARACTER SET" (OCTALSTRING C]
                               (IF (SETQ POS (STRPOS "-" (CAR KNOWN)))
                                   THEN (FOR I FROM (CL:PARSE-INTEGER (SUBSTRING
                                                                                   (CAR KNOWN)
                                                                                   1
                                                                                   (SUB1 POS))
                                                                       :RADIX 8)
                                               TO (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN)
                                                                               (ADD1 POS))
                                                             :RADIX 8)
                                               COLLECT (LIST I (OCTALSTRING I)
                                                                 (CADR KNOWN)))
                                 ELSE (CONS (CONS (CL:PARSE-INTEGER (CAR KNOWN)
                                                             :RADIX 8)
                                                      KNOWN]
         (SETQ IMAPPING (FOR M CSI IN MAPPING WHEN (SETQ CSI (ASSOC (LRSH (CAR M)
                                                                                      8)
                                                                                ICSETS))
                           COLLECT 

                                 (* ;; "The attested subset of INCLUDED")

                                 (CL:UNLESS (MEMB CSI CSETINFO)
                                        (PUSH CSETINFO CSI))
                                 M))

         (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges")

         (SETQ CSETINFO (SORT CSETINFO T))
         [SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO
                                                           COLLECT (CAR CSI)) WHILE CTAIL
                         COLLECT (SETQ START (CAR CTAIL))
                               (SETQ END START)
                               (CONS START (WHILE [AND (CDR CTAIL)
                                                           (EQ END (SUB1 (CADR CTAIL]
                                              COLLECT (SETQ CTAIL (CDR CTAIL))
                                                    (SETQ END (CAR CTAIL]

         (* ;; "Split out groups of less than 3.  But if a range exhaustively covers a known subset (like JIS), replace by the name")

         [SETQ RANGES (FOR R STR KNOWN LAST IN RANGES
                         JOIN (SETQ LAST (CAR (LAST R)))
                               (IF (EQ (CAR R)
                                           LAST)
                                   THEN (CONS (OCTALSTRING (CAR R)))
                                 ELSEIF (SETQ KNOWN (SASSOC (SETQ STR (CONCAT (OCTALSTRING
                                                                                   (CAR R))
                                                                                 "-"
                                                                                 (OCTALSTRING LAST)))
                                                               XCCS-SET-NAMES))
                                   THEN (CONS (CADR KNOWN))
                                 ELSEIF (CDDR R)
                                   THEN (CONS STR)
                                 ELSE (LIST (OCTALSTRING (CAR R))
                                                (OCTALSTRING LAST]
         (CL:VALUES IMAPPING CSETINFO RANGES])

(WRITE-UNICODE-MAPPING-HEADER
  [LAMBDA (STREAM CSETINFO RANGES)                      (* ; "Edited  4-Aug-2020 17:38 by rmk:")

    (* ;; "Writes the standard per-file header information")

    (FOR LINE IN UNICODE-MAPPING-HEADER
       DO (PRINTOUT STREAM "#" 2)
             (SELECTQ LINE
                 (XCCSCHARACTERSETS 
                      (PRINTOUT STREAM "        XCCS charset")
                      (IF (CDR CSETINFO)
                          THEN (PRINTOUT STREAM "s:" -4)
                                (FOR R IN RANGES DO (PRINTOUT STREAM R " "))
                                (TERPRI STREAM)
                        ELSE                             (* ; "Singleton")
                              (PRINTOUT STREAM ": " -4 (CADAR CSETINFO)
                                     " "
                                     (CADDAR CSETINFO)))
                      (TERPRI STREAM))
                 (DATE (PRINTOUT STREAM "        Date:" -13 (DATE (DATEFORMAT NO.TIME 
                                                                         NO.LEADING.SPACES))
                              T))
                 (PRINTOUT STREAM LINE T)))
    (TERPRI STREAM])

(WRITE-UNICODE-MAPPING-FILENAME
  [LAMBDA (FILE CSETINFO RANGES)                        (* ; "Edited  4-Aug-2020 19:34 by rmk:")
    (PACKFILENAME 'BODY [OR FILE (CONCATLIST
                                  (CONS 'XCCS- (IF (CDR CSETINFO)
                                                   THEN (FOR RTAIL R ON RANGES
                                                               JOIN (SETQ R (CAR RTAIL))
                                                                     (SETQ R
                                                                      (CL:IF (LISTP R)
                                                                          (LIST (CAR R)
                                                                                "-"
                                                                                (CDR R))
                                                                          (CONS R)))
                                                                     (CL:IF (CDR RTAIL)
                                                                            (NCONC1 R ","))
                                                                     R)
                                                 ELSE (LIST (CADAR CSETINFO)
                                                                "="
                                                                (CADDAR CSETINFO]
           'DIRECTORY
           (CAR UNICODEDIRECTORIES)
           'EXTENSION
           'TXT])
)

(RPAQQ XCCS-SET-NAMES
       (("0" LATIN)
        ("41" SYMBOLS1)
        ("42" SYMBOLS2)
        ("43" EXTENDED-LATIN)
        ("44" HIRAGANA)
        ("45" KATAKANA)
        ("46" GREEK)
        ("47" CYRILLIC)
        ("50" FORMS)
        ("60-172" JIS)
        ("340" ARABIC)
        ("341" HEBREW)
        ("342" IPA)
        ("343" HANGUL)
        ("344" GEORGIAN-ARMENIAN)
        ("356" SYMBOLS3)
        ("357" SYMBOLS4)
        ("360" LIGATURES)
        ("361" ACCENTED-LATIN)
        ("365" MORE-ARABIC)
        ("375" GRAPHIC-VARIANTS)))



(* ;; "Automate dumping of a documentation prefix")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQ MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16))

(RPAQ UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16))


(CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16))
       (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16)))
)
)

(RPAQQ UNICODE-MAPPING-HEADER
       ("" "        Name:             XCCS (XC-3-1-1-0) to Unicode" "        Unicode version:  3.0" 
           XCCSCHARACTERSETS "        Table version:    0.1" "        Table format:     Format A" 
           DATE "        Author:           Ron Kaplan <Ron.Kaplan@post.harvard.edu>" "" 
           "This file contains mappings from the Xerox Character Code Standard (version" 
           "XC1-3-3-0, 1987) into Unicode 3.0. standard codes.  That is the version of" 
           "XCCS corresponding to the fonts in the Medley system." "" 
           "The format of this file conforms to the format of the other Unicode-supplied" 
           "mapping files:" "   Three white-space (tab or spaces) separated columns:" 
           "     Column 1 is the XCCS code (as hex 0xXXXX)" 
           "     Column 2 is the corresponding Unicode (as hex 0xXXXX)" 
           "     Column 3 (after #) is a comment column. For convenience, it contains the" 
           "        Unicode character itself (since the Unicode character names" 
           "        are not available)" 
           "Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED" 
           "Unicode FFFE is used for XCCS codes that have not yet been filled in." 
           "(Column 3 = MISSING)" "" "This file is encoded in UTF8, so that the Unicode characters" 
           "are properly displayed in Column 3 and can be edited by standard" 
           "Unicode-enabled editors (e.g. Mac Textedit)." "" 
           "This file can also be read by the function" 
           "READ-UNICODE-MAPPING in the UNICODE Medley library package." "" 
           "The entries are in XCCS order and grouped by character sets.  In front of" 
           "the mappings, for convenience, there is a line with the octal XCCS" 
           "character set, after #." "" 
           "Note that a given XCCS code might map to codes in several different Unicode" 
           "positions, since there are repetitions in the Unicode standard." "" 
           "For more details, see the associated README.TXT file." "" 
           "Any comments or problems, contact <ron.kaplan@post.harvard.edu>"))

(RPAQ? UNICODEDIRECTORIES NIL)

(PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR")
                                       '/unicode/xerox/))



(* ;; "Set up translation tables for UTF8 and UTFBE external formats")

(DEFINEQ

(MAKE-UNICODE-TRANSLATION-TABLES
  [LAMBDA (MAPPING LTORVAR RTOLVAR)                     (* ; "Edited 17-Aug-2020 08:46 by rmk:")

    (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to a Unicode mapping file.")

    (* ;; "This 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).")

    (* ;; "")

    (* ;; "We assume that the left-to-right mapping into Unicode is functional, so that each left code maps to a unique right (Unicode) code, because Unicode is presumably the most refined coding scheme.  But several Unicode codes may map to the same left code, for logically different codes that happen to have the same glyphs. In that case the heuristic is to map each %"from%" code to the lowest of the possible %"to%" codes. This means that round-trip reading/writing or writing/reading from one or both starting points may not always be lossless.")

    (* ;; " ")

    (* ;; " Each recoding array has 256 elements, one for each possible high-order byte of a character code.  An array entry is either NIL, a 256-array of codes indexed by low-order bytes, or an alist of (lower-order-bytes . codes).  The latter is used to save space for sparsely populated character sets.")

    (* ;; "")

    (* ;; "The element 256 of each array contains a hash table for characters that might be encountered in XCCS memory or Unicode files for which there is no mapping.  Element 257 contains the corresponding inverse unmapped hash-array, so that UNICODE.TRANSLATE can update them consistently.")

    (* ;; "")

    (* ;; "UNICODE.TRANSLATE assigns an unmapped Unicode character to a %"not used%" XCCS code position (from 5,0 to 40,FF, leaving other low not-used sets for other internal uses (TEDIT?).")

    (* ;; "")

    (* ;; 
  "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF")

    (* ;; "")

    (* ;; "For the convenience of not having to deal with the multiple values, if LTORVAR or RTOLVAR are given, they are set to the constructed arrays before return.")

    (* ;; "")

    (LET ((LTORARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS)
                            :INITIAL-ELEMENT NIL))
          (RTOLARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS)
                            :INITIAL-ELEMENT NIL)))

         (* ;; "The left-to-right direction (into Unicode).    We start by distributing the mappings into alists in arrays indexed by the higher-order (charaset set byte).  The second loop converts long alists into arrays.")

         [FOR M LEFTC RBASE RCODES IN MAPPING EACHTIME (SETQ RCODES (CDR M))
                                                            (SETQ RBASE (CAR RCODES))
            UNLESS (IGEQ RBASE MISSINGCODE) DO (SETQ LEFTC (CAR M)) 

                                                      (* ;; 
                                                    "(CDR RCODES) contains combiners on the base")

                                                      (CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK)
                                                                     (CL:IF (CDR RCODES)
                                                                         RCODES
                                                                         RBASE))
                                                             (CL:SVREF LTORARRAY (LRSH LEFTC 
                                                                                    TRANSLATION-SHIFT
                                                                                       ]
         (FOR I CSA FROM 0 TO (SUB1 N-TRANSLATION-SEGMENTS)
            WHEN (IGREATERP (LENGTH (CL:SVREF LTORARRAY I))
                            MAX-ALIST-LENGTH)
            DO 

                  (* ;; "Leave it alone if the alist is short")

                  (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
                  (FOR P IN (CL:SVREF LTORARRAY I)
                     DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P)
                                                          TRANSLATION-MASK))
                                   (CDR P)))
                  (CL:SETF (CL:SVREF LTORARRAY I)
                         CSA))

         (* ;; "")

         (* ;; "Now the right-to-left direction (from Unicode). Here we have to detect and compensate for ambiguity.")

         (FOR M LEFTC RBASE RCOMBINERS PREV IN MAPPING EACHTIME (SETQ RBASE (CADR M))
                                                                     (SETQ RCOMBINERS (CDDR M))
            UNLESS (OR (IGEQ RBASE MISSINGCODE)
                           RCOMBINERS) DO 

                                             (* ;; 
                                     "Have we already seen an explicit mapping from right to left?")

                                             (SETQ LEFTC (CAR M))
                                             [SETQ PREV (ASSOC (LOGAND RBASE TRANSLATION-MASK)
                                                               (CL:SVREF RTOLARRAY (LRSH RBASE 
                                                                                    TRANSLATION-SHIFT
                                                                                         ]
                                             (IF (NULL PREV)
                                                 THEN (CL:PUSH (CONS (LOGAND RBASE 
                                                                                TRANSLATION-MASK)
                                                                         LEFTC)
                                                                 (CL:SVREF RTOLARRAY (LRSH RBASE 
                                                                                    TRANSLATION-SHIFT
                                                                                           )))
                                               ELSEIF (IGREATERP (CDR PREV)
                                                                 LEFTC)
                                                 THEN (RPLACD PREV LEFTC)))
         (FOR I CSA FROM 0 TO (SUB1 N-TRANSLATION-SEGMENTS)
            WHEN (IGREATERP (LENGTH (CL:SVREF RTOLARRAY I))
                            MAX-ALIST-LENGTH)
            DO 

                  (* ;; "Long list, make an array")

                  (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
                  (FOR P IN (CL:SVREF RTOLARRAY I)
                     DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P)
                                                          TRANSLATION-MASK))
                                   (CDR P)))
                  (CL:SETF (CL:SVREF RTOLARRAY I)
                         CSA))

         (* ;; "")

         (* ;; "Allocate the hash arrays for future out-of-map codes.  We we have to keep track of the next available and last possible codes, as well as the first available, for error checking.")

         (CL:SETF (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS)
                (LIST (HASHARRAY 10)
                      (CHARCODE.DECODE "5,0")
                      (CHARCODE.DECODE "40,0")
                      (CHARCODE.DECODE "5,0")))
         (CL:SETF (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS)
                (LIST (HASHARRAY 10)
                      (CHARCODE.DECODE "E000")
                      (CHARCODE.DECODE "F8FF")
                      (CHARCODE.DECODE "E000")))

         (* ;; "Now put in the inverse unmapped hash arrays")

         (CL:SETF (CL:SVREF LTORARRAY (ADD1 N-TRANSLATION-SEGMENTS))
                (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS))
         (CL:SETF (CL:SVREF RTOLARRAY (ADD1 N-TRANSLATION-SEGMENTS))
                (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS))

         (* ;; "")

         (CL:WHEN LTORVAR (SETATOMVAL LTORVAR LTORARRAY))
         (CL:WHEN RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY))
         (CL:VALUES LTORARRAY RTOLARRAY])
)

(RPAQ? DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 
                                         ACCENTED-LATIN))
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(MAKE-UNICODE-TRANSLATION-TABLES (READ-UNICODE-MAPPING DEFAULT-XCCS-CHARSETS T)
       '*XCCSTOUNICODE*
       '*UNICODETOXCCS*)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*)
)
(DEFINEQ

(HEXSTRING
  [LAMBDA (N WIDTH)                                     (* ; "Edited 23-Jul-2020 08:28 by rmk:")
                                                             (* ; "Edited 20-Dec-93 17:51 by rmk:")

    (* ;; 
  "Converts positive numbers to Hex strings, padding on the right with 0 up to WIDTH if given.")

    (CL:UNLESS (FIXP N)
        (SETQ N (CHARCODE.DECODE N)))
    (LET [CHAR (STR (ALLOCSTRING [IMAX (OR WIDTH 0)
                                       (FOR I (LEFT _ N) FROM 0 UNTIL (EQ LEFT 0)
                                          DO (SETQ LEFT (LRSH LEFT 4))
                                          FINALLY (RETURN (MAX I 1]
                           (CHARCODE 0]
         (FOR I FROM -1 BY -1 UNTIL (EQ N 0)
            DO (SETQ CHAR (LOGAND N 15))
                  [RPLCHARCODE STR I (IF (ILESSP CHAR 10)
                                         THEN (+ CHAR (CHARCODE 0))
                                       ELSE (+ (- CHAR 10)
                                                   (CHARCODE A]
                  (SETQ N (LRSH N 4)))
         STR])

(UTF8HEXSTRING
  [LAMBDA (CHARCODE)                                    (* ; "Edited 10-Aug-2020 08:33 by rmk:")

    (* ;; "Utility to produces the UTF8 hexstring representing CODE")

    (HEXSTRING (IF (ILESSP CHARCODE 128)
                       THEN CHARCODE
                     ELSEIF (ILESSP CHARCODE 2048)
                       THEN                              (* ; "x800")
                             (LOGOR (LLSH (LOGOR (LLSH 3 6)
                                                 (LRSH CHARCODE 6))
                                          8)
                                    (LOGOR (LLSH 2 6)
                                           (LOADBYTE CHARCODE 0 6)))
                     ELSEIF (ILESSP CHARCODE 65536)
                       THEN                              (* ; "x10000")
                             (LOGOR (LLSH (LOGOR (LLSH 7 5)
                                                 (LRSH CHARCODE 12))
                                          16)
                                    (LLSH (LOGOR (LLSH 2 6)
                                                 (LOADBYTE CHARCODE 6 6))
                                          8)
                                    (LOGOR (LLSH 2 6)
                                           (LOADBYTE CHARCODE 0 6)))
                     ELSEIF (ILESSP CHARCODE 2097152)
                       THEN                              (* ; "x200000")
                             (LOGOR (LLSH (LOGOR (LLSH 15 4)
                                                 (LRSH CHARCODE 18))
                                          24)
                                    (LLSH (LOGOR (LLSH 2 6)
                                                 (LOADBYTE CHARCODE 12 6))
                                          16)
                                    (LLSH (LOGOR (LLSH 2 6)
                                                 (LOADBYTE CHARCODE 6 6))
                                          8)
                                    (LOGOR (LLSH 2 6)
                                           (LOADBYTE CHARCODE 0 6)))
                     ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE])

(NUTF8CODEBYTES
  [LAMBDA (N)                                           (* ; "Edited 10-Aug-2020 12:35 by rmk:")

    (* ;; "Returns the number of bytes needed to encode N in UTF8, ")

    (IF (ILESSP N 128)
        THEN 1
      ELSEIF (ILESSP N 2048)
        THEN                                             (* ; "x800")
              4
      ELSEIF (ILESSP N 65536)
        THEN                                             (* ; "x10000")
              3
      ELSEIF (ILESSP N 2097152)
        THEN                                             (* ; "x200000")
              2
      ELSE (SHOULDNT])

(NUTF8STRINGBYTES
  [LAMBDA (STRING RAWFLG)                               (* ; "Edited 10-Aug-2020 09:06 by rmk:")

    (* ;; "Returns the number of bytes it would take to represent STRING in UTF8, assuming it is an XCCS string unless RAWFLG. ")

    (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE STRING I))
       SUM (NUTF8CODEBYTES (CL:IF RAWFLG
                                       C
                                       (XTOUCODE C))])

(XTOUSTRING
  [LAMBDA (XCCSSTRING RAWFLG)                           (* ; "Edited 10-Aug-2020 21:42 by rmk:")

    (* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XCCSSTRING.  Applies the XCCSTOUNICODE translation unless RAWFLG.  ")

    (* ;; "The resulting string will not be readable inside Medley.")

    (LET [(USTR (ALLOCSTRING (NUTF8STRINGBYTES XCCSSTRING RAWFLG]
         (FOR I CHARCODE (SINDEX _ 0) FROM 1 WHILE (SETQ CHARCODE (NTHCHARCODE XCCSSTRING
                                                                                     I))
            DO (CL:UNLESS RAWFLG
                       (SETQ CHARCODE (XTOUCODE CHARCODE)))
                  (IF (ILESSP CHARCODE 128)
                      THEN (RPLCHARCODE USTR (ADD SINDEX 1)
                                      CHARCODE)
                    ELSEIF (ILESSP CHARCODE 2048)
                      THEN                               (* ; "x800")
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 3 6)
                                          (LRSH CHARCODE 6)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 0 6)))
                    ELSEIF (ILESSP CHARCODE 65536)
                      THEN                               (* ; "x10000")
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 7 5)
                                          (LRSH CHARCODE 12)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 6 6)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 0 6)))
                    ELSEIF (ILESSP CHARCODE 2097152)
                      THEN                               (* ; "x200000")
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 15 4)
                                          (LRSH CHARCODE 18)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 12 6)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 6 6)))
                            (RPLCHARCODE USTR (ADD SINDEX 1)
                                   (LOGOR (LLSH 2 6)
                                          (LOADBYTE CHARCODE 0 6)))
                    ELSE (SHOULDNT)))
         USTR])

(XCCSSTRING
  [LAMBDA (CODE)                                        (* ; "Edited 13-Aug-2020 12:16 by rmk:")

    (* ;; "Returns XCCS character representation of string %"cset,char%"")

    (CL:UNLESS (FIXP CODE)
        (SETQ CODE (CHCON1 CODE)))
    (CONCAT (OCTALSTRING (LRSH CODE 8))
           ","
           (OCTALSTRING (LOGAND CODE 255])
)
(DEFINEQ

(SHOWCHARS
  [LAMBDA (FROMCHAR TOCHAR FONT)                        (* ; "Edited  1-Aug-2020 09:27 by rmk:")
    (RESETFORM (DSPFONT (OR FONT '(CLASSIC 12))
                      T)
           (CL:WHEN (AND (SMALLP FROMCHAR)
                         (NOT TOCHAR))

               (* ;; 
    "If a small number, assume it's an octal (in decimal) character set, no need for string quotes")

               (SETQ TOCHAR (CONCAT FROMCHAR "," 376))
               (SETQ FROMCHAR (CONCAT FROMCHAR "," 41)))
           (CL:UNLESS (SMALLP FROMCHAR)
               (SETQ FROMCHAR (CHARCODE.DECODE FROMCHAR)))
           (CL:UNLESS (SMALLP TOCHAR)
               (SETQ TOCHAR (CL:IF TOCHAR
                                (CHARCODE.DECODE TOCHAR)
                                FROMCHAR)))
           (FOR C FROM FROMCHAR TO TOCHAR UNLESS (AND (IGEQ (LOGAND C 255)
                                                                            127)
                                                                      (ILEQ (LOGAND C 255)
                                                                            (PLUS 128 33)))
              DO (PRINTOUT T .P2 (CONCAT (OCTALSTRING (LRSH CODE 8))
                                            ","
                                            (OCTALSTRING (LOGAND CODE 255)))
                            10
                            (CHARACTER C)
                            T])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ LF.EOLC 1)

(RPAQQ CR.EOLC 0)

(RPAQQ CRLF.EOLC 2)


(CONSTANTS (LF.EOLC 1)
       (CR.EOLC 0)
       (CRLF.EOLC 2))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ TRANSLATION-SEGMENT-SIZE 128)

(RPAQQ MAX-ALIST-LENGTH 10)

(RPAQ N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE))

(RPAQ TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE)))

(RPAQ TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE))


(CONSTANTS (TRANSLATION-SEGMENT-SIZE 128)
       (MAX-ALIST-LENGTH 10)
       (N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE))
       (TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE)))
       (TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE)))
)


(EVAL (SYSRECLOOK1 'EXTERNALFORMAT))

(EVAL (SYSRECLOOK1 'STREAM))
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4053 16237 (UTF8.OUTCHARFN 4063 . 6347) (UTF8.INCCODEFN 6349 . 10448) (UTF8.PEEKCCODEFN
 10450 . 15728) (\UTF8.BACKCHARFN 15730 . 16235)) (16238 19560 (UTF16BE.OUTCHARFN 16248 . 16981) (
UTF16BE.INCCODEFN 16983 . 17860) (UTF16BE.PEEKCCODEFN 17862 . 19117) (\UTF16.BACKCHARFN 19119 . 19558)
) (19590 23730 (MAKE-UNICODE-FORMATS 19600 . 23728)) (23827 25133 (UNICODE.UNMAPPED 23837 . 25131)) (
25134 25670 (XCCS-UTF8-AFTER-OPEN 25144 . 25668)) (26740 27089 (XTOUCODE 26750 . 26918) (UTOXCODE 
26920 . 27087)) (27129 43311 (READ-UNICODE-MAPPING-FILENAMES 27139 . 28301) (READ-UNICODE-MAPPING 
28303 . 31600) (WRITE-UNICODE-MAPPING 31602 . 35819) (WRITE-UNICODE-INCLUDED 35821 . 40543) (
WRITE-UNICODE-MAPPING-HEADER 40545 . 41777) (WRITE-UNICODE-MAPPING-FILENAME 41779 . 43309)) (46648 
55017 (MAKE-UNICODE-TRANSLATION-TABLES 46658 . 55015)) (55432 63336 (HEXSTRING 55442 . 56603) (
UTF8HEXSTRING 56605 . 58810) (NUTF8CODEBYTES 58812 . 59475) (NUTF8STRINGBYTES 59477 . 59958) (
XTOUSTRING 59960 . 62971) (XCCSSTRING 62973 . 63334)) (63337 64806 (SHOWCHARS 63347 . 64804)))))
STOP
\ No newline at end of file
diff --git a/library/UNICODE.LCOM b/library/UNICODE.LCOM
index bc8516ac..c14d96b1 100644
Binary files a/library/UNICODE.LCOM and b/library/UNICODE.LCOM differ
diff --git a/loadups/xfull35.dribble b/loadups/xfull35.dribble
index e8fc96f2..8835429b 100644
--- a/loadups/xfull35.dribble
+++ b/loadups/xfull35.dribble
@@ -1 +1 @@
-
Full loadup started at 27-Oct-2020 15:43:11 while connected to 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>POSTSCRIPTSTREAM.LCOM;1
compiled on 14-May-2018 10:53:32
File created 14-May-2018 10:52:48
POSTSCRIPTSTREAMCOMS
Loading FULL fonts...
  Loading CLASSIC 8 10 12 
  Loading MODERN 8 10 12 
  Loading TERMINAL 8 10 12 
  Loading postscript fonts
FULL fonts loaded

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>CHAT.LCOM;1
compiled on 25-Oct-93 12:23:25
File created 20-Jan-93 13:46:52
CHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>DMCHAT.LCOM;1
compiled on 25-Feb-93 18:08:53
File created 20-Jan-93 13:49:09
DMCHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>CHATTERMINAL.LCOM;1
compiled on 24-Feb-93 19:37:23
File created  4-Jul-90 02:21:01
CHATTERMINALCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>NSCHAT.LCOM;1
compiled on 18-Jul-94 10:13:24
File created 12-Sep-91 18:26:50
NSCHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDIT.LCOM;1
compiled on 18-May-2018 09:16:24
File created 19-Apr-2018 12:22:03
TEDITCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITDCL.LCOM;1
compiled on 18-May-2018 09:17:04
File created 25-Aug-94 10:53:00
TEDITDCLCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>PCTREE.LCOM;1
compiled on 18-May-2018 09:19:35
File created 19-Apr-2018 12:19:49
PCTREECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEXTOFD.LCOM;1
compiled on 11-Feb-2001 12:06:43
File created 11-Feb-2001 12:06:42
TEXTOFDCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITCOMMAND.LCOM;1
compiled on 18-May-2018 09:16:59
File created 20-Apr-2018 08:07:35
TEDITCOMMANDCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITSCREEN.LCOM;1
compiled on 18-May-2018 09:18:38
File created 25-Aug-94 13:26:23
TEDITSCREENCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITABBREV.LCOM;1
compiled on  6-Aug-2020 14:52:14
File created  6-Aug-2020 14:52:14
TEDITABBREVCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITLOOKS.LCOM;1
compiled on 18-May-2018 09:17:44
File created 29-Jan-99 17:33:35
TEDITLOOKSCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITFIND.LCOM;1
compiled on 18-May-2018 09:17:21
File created  6-May-2018 17:34:44
TEDITFINDCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITHISTORY.LCOM;1
compiled on 18-May-2018 09:17:41
File created 29-Jan-99 17:34:39
TEDITHISTORYCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITFILE.LCOM;1
compiled on 18-May-2018 09:17:06
File created 19-May-2001 11:45:53
TEDITFILECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITWINDOW.LCOM;1
compiled on 18-May-2018 09:18:51
File created 21-Jun-99 20:00:42
TEDITWINDOWCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITSELECTION.LCOM;1
compiled on 18-May-2018 09:18:43
File created 25-Aug-94 10:56:07
TEDITSELECTIONCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>IMAGEOBJ.LCOM;1
compiled on  8-Feb-97 11:26:32
File created  7-Dec-95 13:21:56
IMAGEOBJCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>EDITBITMAP.LCOM;1
compiled on 25-Feb-93 18:10:27
File created 11-Jun-90 15:42:25
EDITBITMAPCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>READNUMBER.LCOM;1
compiled on 16-Aug-95 11:18:52
File created 25-May-93 00:28:30
READNUMBERCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TFBRAVO.LCOM;1
compiled on 19-Apr-2018 12:19:55
File created 19-Apr-2018 12:19:55
TFBRAVOCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITHCPY.LCOM;1
compiled on 18-May-2018 09:17:32
File created 25-Aug-94 10:54:07
TEDITHCPYCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITPAGE.LCOM;1
compiled on 18-May-2018 09:18:32
File created 25-Aug-94 10:55:28
TEDITPAGECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITMENU.LCOM;1
compiled on 18-May-2018 09:18:07
File created 24-Apr-95 12:05:29
TEDITMENUCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITFNKEYS.LCOM;1
compiled on 18-May-2018 09:17:25
File created  6-May-2018 17:15:13
TEDITFNKEYSCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>HRULE.LCOM;1
compiled on 26-Feb-93 11:26:19
File created  8-Oct-92 16:50:21
HRULECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITCHAT.LCOM;1
compiled on 18-May-2018 09:16:55
File created 28-Mar-94 16:05:24
IL:TEDITCHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>FILEBROWSER.LCOM;1
compiled on 11-Sep-2001 09:26:17
File created 11-Sep-2001 09:26:14

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TABLEBROWSER.LCOM;1
compiled on  1-Dec-2018 17:25:13
File created  1-Dec-2018 17:25:13
TABLEBROWSERCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>THINFILES.LCOM;1
compiled on 26-Jun-99 00:47:00
File created  1-May-92 16:49:39
THINFILESCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>GRAPHER.LCOM;1
compiled on 14-May-2018 10:24:43
File created 14-May-2018 10:24:38
GRAPHERCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>SPY.LCOM;1
compiled on 23-Aug-94 16:33:38
File created 29-Apr-94 14:13:52
SPYCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>WHERE-IS.DFASL;1
XCL Compiler output for source file {DSK}<python>lde>lispcore>library>WHERE-IS.;1
Source file created Wednesday, 13 June 1990, 1:16:15.
FASL file created Thursday, 21 January 1993, 18:52:55.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>HASH-FILE.dfasl;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>HASH-FILE.;2
Source file created Monday, 11 June 1990, 16:16:54.
FASL file created Friday, 26 February 1993, 11:23:40.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>CASH-FILE.DFASL;4
XCL Compiler output for source file {DSK}<usr>local>lde>lispcore>library>CASH-FILE.;2
Source file created 11-Jun-90 14:33:44
FASL file created Saturday, 19 September 2020, 22:04:31


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>COPYFILES.LCOM;1
compiled on  6-Apr-2018 21:14:29
File created  6-Apr-2018 21:14:29
COPYFILESCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MSANALYZE.DFASL;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSANALYZE.;5
Source file created Wednesday, 15 August 1990, 13:11:23.
FASL file created Sunday, 28 February 1993, 23:16:46.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MSPARSE.DFASL;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSPARSE.;5
Source file created Wednesday, 15 August 1990, 13:00:12.
FASL file created Sunday, 28 February 1993, 23:24:50.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.DFASL;3
XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;4
Source file created Saturday, 19 September 2020, 9:54:51.
FASL file created Saturday, 19 September 2020, 9:54:51.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MSCOMMON.DFASL;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSCOMMON.;3
Source file created Monday, 4 May 1992, 13:19:40.
FASL file created Sunday, 28 February 1993, 23:23:14.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXPRINT.DFASL;1
XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXPRINT.;8
Source file created Friday, 4 May 2018, 17:18:00.
FASL file created Friday, 4 May 2018, 17:18:00.


{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXCOMM.LCOM;1
compiled on 25-Apr-2018 07:31:56
File created 25-Apr-2018 07:31:56
UNIXCOMMCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNICODE.LCOM;17
compiled on 17-Aug-2020 08:48:36
File created 17-Aug-2020 08:48:36
UNICODECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>iso8859io.LCOM;4
compiled on  9-Mar-99 18:20:33
File created  9-Mar-99 18:20:26
ISO8859IOCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.LCOM;1
compiled on  8-Aug-2020 15:48:08
File created  8-Aug-2020 15:48:08
CLIPBOARDCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.LCOM;46
compiled on  8-Aug-2020 15:48:17
File created  8-Aug-2020 15:48:17
MACINTERFACECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>PRETTYFILEINDEX.LCOM;2
compiled on 28-Jun-99 17:13:58
File created 28-Jun-99 17:13:51
PRETTYFILEINDEXCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>WHO-LINE.LCOM;1
compiled on 19-Feb-2001 11:57:34
File created 19-Feb-2001 11:53:32
WHO-LINECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>NSCOPYFILE.LCOM;1
compiled on  8-Jun-94 17:54:54
File created 10-Dec-87 11:40:53
NSCOPYFILECOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXCHAT.LCOM;1
compiled on 21-Jan-93 18:45:15
File created 15-Aug-90 11:05:53
UNIXCHATCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXTELNET.LCOM;1
compiled on 18-Jul-94 23:29:48
File created 16-Feb-90 17:00:31
UNIXTELNETCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>SETDEFAULTPRINTER.LCOM;2
compiled on 12-Nov-98 17:41:28
File created  7-Jun-93 15:34:58
SETDEFAULTPRINTERCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>DEFAULTSUBITEMFN.LCOM;1
compiled on  8-Sep-94 20:23:23
File created  4-Mar-87 15:59:01
DEFAULTSUBITEMFNCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>LoadPatches.;1
File created 16-Nov-88 14:11:42
LOADPATCHESCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>NOXNSPATCH.LCOM;1
compiled on 31-Mar-99 17:08:42
File created 31-Mar-99 17:08:40
NOXNSPATCHCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>LLREADPATCH.LCOM;5
compiled on  1-Aug-2020 18:52:48
File created  1-Aug-2020 18:52:48
LLREADPATCHCOMS

{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>MACHINEINDEPENDENTPATCH.LCOM;2
compiled on 19-Sep-2020 21:18:45
File created 19-Sep-2020 20:56:09
MACHINEINDEPENDENTPATCHCOMS
About to end loadup
Creating FULL sysout on 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>/loadups/xfull35.sysout
\ No newline at end of file
+
Full loadup started at 29-Nov-2020 10:51:08 while connected to 
{DSK}<home>larry>ilisp>medley>


{DSK}<home>larry>ilisp>medley>library>POSTSCRIPTSTREAM.LCOM;1
compiled on 14-May-2018 10:53:32
File created 14-May-2018 10:52:48
POSTSCRIPTSTREAMCOMS
Loading FULL fonts...
  Loading CLASSIC 8 10 12 
  Loading MODERN 8 10 12 
  Loading TERMINAL 8 10 12 
  Loading postscript fonts
FULL fonts loaded

{DSK}<home>larry>ilisp>medley>library>CHAT.LCOM;1
compiled on 25-Oct-93 12:23:25
File created 20-Jan-93 13:46:52
CHATCOMS

{DSK}<home>larry>ilisp>medley>library>DMCHAT.LCOM;1
compiled on 25-Feb-93 18:08:53
File created 20-Jan-93 13:49:09
DMCHATCOMS

{DSK}<home>larry>ilisp>medley>library>CHATTERMINAL.LCOM;1
compiled on 24-Feb-93 19:37:23
File created  4-Jul-90 02:21:01
CHATTERMINALCOMS

{DSK}<home>larry>ilisp>medley>library>TEDIT.LCOM;1
compiled on 18-May-2018 09:16:24
File created 19-Apr-2018 12:22:03
TEDITCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITDCL.LCOM;1
compiled on 18-May-2018 09:17:04
File created 25-Aug-94 10:53:00
TEDITDCLCOMS

{DSK}<home>larry>ilisp>medley>library>PCTREE.LCOM;1
compiled on 18-May-2018 09:19:35
File created 19-Apr-2018 12:19:49
PCTREECOMS

{DSK}<home>larry>ilisp>medley>library>TEXTOFD.LCOM;1
compiled on 11-Feb-2001 12:06:43
File created 11-Feb-2001 12:06:42
TEXTOFDCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITCOMMAND.LCOM;1
compiled on 18-May-2018 09:16:59
File created 20-Apr-2018 08:07:35
TEDITCOMMANDCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITSCREEN.LCOM;1
compiled on 18-May-2018 09:18:38
File created 25-Aug-94 13:26:23
TEDITSCREENCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITABBREV.LCOM;1
compiled on  6-Aug-2020 14:52:14
File created  6-Aug-2020 14:52:14
TEDITABBREVCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITLOOKS.LCOM;1
compiled on 18-May-2018 09:17:44
File created 29-Jan-99 17:33:35
TEDITLOOKSCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITFIND.LCOM;1
compiled on 18-May-2018 09:17:21
File created  6-May-2018 17:34:44
TEDITFINDCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITHISTORY.LCOM;1
compiled on 18-May-2018 09:17:41
File created 29-Jan-99 17:34:39
TEDITHISTORYCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITFILE.LCOM;1
compiled on 18-May-2018 09:17:06
File created 19-May-2001 11:45:53
TEDITFILECOMS

{DSK}<home>larry>ilisp>medley>library>TEDITWINDOW.LCOM;1
compiled on 18-May-2018 09:18:51
File created 21-Jun-99 20:00:42
TEDITWINDOWCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITSELECTION.LCOM;1
compiled on 18-May-2018 09:18:43
File created 25-Aug-94 10:56:07
TEDITSELECTIONCOMS

{DSK}<home>larry>ilisp>medley>library>IMAGEOBJ.LCOM;1
compiled on  8-Feb-97 11:26:32
File created  7-Dec-95 13:21:56
IMAGEOBJCOMS

{DSK}<home>larry>ilisp>medley>library>EDITBITMAP.LCOM;1
compiled on 25-Feb-93 18:10:27
File created 11-Jun-90 15:42:25
EDITBITMAPCOMS

{DSK}<home>larry>ilisp>medley>library>READNUMBER.LCOM;1
compiled on 16-Aug-95 11:18:52
File created 25-May-93 00:28:30
READNUMBERCOMS

{DSK}<home>larry>ilisp>medley>library>TFBRAVO.LCOM;1
compiled on 19-Apr-2018 12:19:55
File created 19-Apr-2018 12:19:55
TFBRAVOCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITHCPY.LCOM;1
compiled on 18-May-2018 09:17:32
File created 25-Aug-94 10:54:07
TEDITHCPYCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITPAGE.LCOM;1
compiled on 18-May-2018 09:18:32
File created 25-Aug-94 10:55:28
TEDITPAGECOMS

{DSK}<home>larry>ilisp>medley>library>TEDITMENU.LCOM;1
compiled on 18-May-2018 09:18:07
File created 24-Apr-95 12:05:29
TEDITMENUCOMS

{DSK}<home>larry>ilisp>medley>library>TEDITFNKEYS.LCOM;1
compiled on 18-May-2018 09:17:25
File created  6-May-2018 17:15:13
TEDITFNKEYSCOMS

{DSK}<home>larry>ilisp>medley>library>HRULE.LCOM;1
compiled on 26-Feb-93 11:26:19
File created  8-Oct-92 16:50:21
HRULECOMS

{DSK}<home>larry>ilisp>medley>library>TEDITCHAT.LCOM;1
compiled on 18-May-2018 09:16:55
File created 28-Mar-94 16:05:24
IL:TEDITCHATCOMS

{DSK}<home>larry>ilisp>medley>library>FILEBROWSER.LCOM;1
compiled on 11-Sep-2001 09:26:17
File created 11-Sep-2001 09:26:14

{DSK}<home>larry>ilisp>medley>library>TABLEBROWSER.LCOM;1
compiled on  1-Dec-2018 17:25:13
File created  1-Dec-2018 17:25:13
TABLEBROWSERCOMS

{DSK}<home>larry>ilisp>medley>lispusers>THINFILES.LCOM;1
compiled on 26-Jun-99 00:47:00
File created  1-May-92 16:49:39
THINFILESCOMS

{DSK}<home>larry>ilisp>medley>library>GRAPHER.LCOM;1
compiled on 14-May-2018 10:24:43
File created 14-May-2018 10:24:38
GRAPHERCOMS

{DSK}<home>larry>ilisp>medley>library>SPY.LCOM;1
compiled on 23-Aug-94 16:33:38
File created 29-Apr-94 14:13:52
SPYCOMS

{DSK}<home>larry>ilisp>medley>library>WHERE-IS.DFASL;1
XCL Compiler output for source file {DSK}<python>lde>lispcore>library>WHERE-IS.;1
Source file created Wednesday, 13 June 1990, 1:16:15.
FASL file created Thursday, 21 January 1993, 18:52:55.


{DSK}<home>larry>ilisp>medley>library>HASH-FILE.dfasl;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>HASH-FILE.;2
Source file created Monday, 11 June 1990, 16:16:54.
FASL file created Friday, 26 February 1993, 11:23:40.


{DSK}<home>larry>ilisp>medley>library>CASH-FILE.DFASL;5
XCL Compiler output for source file {DSK}<usr>local>lde>lispcore>library>CASH-FILE.;2
Source file created 11-Jun-90 14:33:44
FASL file created Saturday, 19 September 2020, 22:04:31


{DSK}<home>larry>ilisp>medley>library>COPYFILES.LCOM;1
compiled on  6-Apr-2018 21:14:29
File created  6-Apr-2018 21:14:29
COPYFILESCOMS

{DSK}<home>larry>ilisp>medley>library>MSANALYZE.DFASL;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSANALYZE.;5
Source file created Wednesday, 15 August 1990, 13:11:23.
FASL file created Sunday, 28 February 1993, 23:16:46.


{DSK}<home>larry>ilisp>medley>library>MSPARSE.DFASL;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSPARSE.;5
Source file created Wednesday, 15 August 1990, 13:00:12.
FASL file created Sunday, 28 February 1993, 23:24:50.


{DSK}<home>larry>ilisp>medley>library>MASTERSCOPE.DFASL;4
XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;4
Source file created Saturday, 19 September 2020, 9:54:51.
FASL file created Saturday, 19 September 2020, 9:54:51.


{DSK}<home>larry>ilisp>medley>library>MSCOMMON.DFASL;1
XCL Compiler output for source file {PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSCOMMON.;3
Source file created Monday, 4 May 1992, 13:19:40.
FASL file created Sunday, 28 February 1993, 23:23:14.


{DSK}<home>larry>ilisp>medley>library>UNIXPRINT.DFASL;1
XCL Compiler output for source file {DSK}<Users>kaplan>Local>medley3.5>lispcore>library>UNIXPRINT.;8
Source file created Friday, 4 May 2018, 17:18:00.
FASL file created Friday, 4 May 2018, 17:18:00.


{DSK}<home>larry>ilisp>medley>library>UNIXCOMM.LCOM;1
compiled on 25-Apr-2018 07:31:56
File created 25-Apr-2018 07:31:56
UNIXCOMMCOMS

{DSK}<home>larry>ilisp>medley>library>UNICODE.LCOM;19
compiled on 29-Nov-2020 10:50:35
File created 29-Nov-2020 10:50:18
UNICODECOMS

{DSK}<home>larry>ilisp>medley>lispusers>HELPSYS.LCOM;2
compiled on 27-Nov-2020 11:23:11
File created 27-Nov-2020 09:47:44
HELPSYSCOMS

{DSK}<home>larry>ilisp>medley>lispusers>DINFO.LCOM;2
compiled on 27-Nov-2020 09:16:14
File created 27-Nov-2020 09:14:02
DINFOCOMS

{DSK}<home>larry>ilisp>medley>library>HASH.LCOM;1
compiled on 26-Feb-93 11:22:10
File created 11-Jun-90 16:23:11
HASHCOMS

{DSK}<home>larry>ilisp>medley>library>CLIPBOARD.LCOM;1
compiled on  8-Aug-2020 15:48:08
File created  8-Aug-2020 15:48:08
CLIPBOARDCOMS

{DSK}<home>larry>ilisp>medley>lispusers>MACINTERFACE.LCOM;47
compiled on  8-Aug-2020 15:48:17
File created  8-Aug-2020 15:48:17
MACINTERFACECOMS

{DSK}<home>larry>ilisp>medley>lispusers>ISO8859IO.LCOM;1
compiled on  9-Mar-99 18:20:33
File created  9-Mar-99 18:20:26
ISO8859IOCOMS

{DSK}<home>larry>ilisp>medley>lispusers>PRETTYFILEINDEX.LCOM;3
compiled on 28-Jun-99 17:13:58
File created 28-Jun-99 17:13:51
PRETTYFILEINDEXCOMS

{DSK}<home>larry>ilisp>medley>lispusers>WHO-LINE.LCOM;1
compiled on 19-Feb-2001 11:57:34
File created 19-Feb-2001 11:53:32
WHO-LINECOMS

{DSK}<home>larry>ilisp>medley>library>UNIXCHAT.LCOM;1
compiled on 21-Jan-93 18:45:15
File created 15-Aug-90 11:05:53
UNIXCHATCOMS

{DSK}<home>larry>ilisp>medley>library>UNIXTELNET.LCOM;1
compiled on 18-Jul-94 23:29:48
File created 16-Feb-90 17:00:31
UNIXTELNETCOMS

{DSK}<home>larry>ilisp>medley>lispusers>SETDEFAULTPRINTER.LCOM;3
compiled on 12-Nov-98 17:41:28
File created  7-Jun-93 15:34:58
SETDEFAULTPRINTERCOMS

{DSK}<home>larry>ilisp>medley>lispusers>DEFAULTSUBITEMFN.LCOM;1
compiled on  8-Sep-94 20:23:23
File created  4-Mar-87 15:59:01
DEFAULTSUBITEMFNCOMS

{DSK}<home>larry>ilisp>medley>lispusers>LoadPatches.;1
File created 16-Nov-88 14:11:42
LOADPATCHESCOMS
About to end loadup
Creating FULL sysout on {DSK}<home>larry>ilisp>medley>loadups/xfull35.sysout
\ No newline at end of file
diff --git a/loadups/xfull35.sysout b/loadups/xfull35.sysout
index cba36507..f2ec9da3 100644
Binary files a/loadups/xfull35.sysout and b/loadups/xfull35.sysout differ
diff --git a/makesysout/makefullsysout b/makesysout/makefullsysout
index 758b23a4..93d1fcbe 100644
--- a/makesysout/makefullsysout
+++ b/makesysout/makefullsysout
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "28-Nov-2020 16:56:44" {DSK}<home>larry>ilisp>medley>makesysout>makefullsysout.;105 14394  

      changes to%:  (COMMANDS "cd" "pwd" "ls")
                    (FNS LOADFULLFONTS LOADNFS MAKEFULLSYSOUT)

      previous date%: "28-Nov-2020 10:41:31" 
{DSK}<home>larry>ilisp>medley>makesysout>makefullsysout.;104)


(PRETTYCOMPRINT MAKEFULLSYSOUTCOMS)

(RPAQQ MAKEFULLSYSOUTCOMS
       ((COMMANDS "cd" "pwd" "ls")
        (FNS LOADFULLFONTS LOADNFS MAKEFULLSYSOUT PAGEHEIGHT FIXMETA)
        (P (FIXMETA))
        (FNS LoadPatches COLLECT-PATCH-FILES)
        (INITVARS (WRITEFULLSYSOUTFLAG T))
        (VARS (COPYRIGHTFLG NIL))
        (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
        (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAKEFULLSYSOUT)))
        (PROP FILETYPE MAKEFULLSYSOUT)))

(DEFCOMMAND "cd" (DIR) (/CNDIR DIR))

(DEFCOMMAND "pwd" NIL (DIRECTORYNAME T))

(DEFCOMMAND "ls" (FIRST . REST) (DODIR (CONS FIRST REST)))
(DEFINEQ

(LOADFULLFONTS
  [LAMBDA (ROOTDIRECTORY)                                    (* ; 
                                                           "Edited 11-Aug-2020 17:53 by rmk:")

    (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q")

    (PRINTOUT T "Loading FULL fonts..." T)
    (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts")
                                       (PACK* ROOTDIRECTORY "/fonts/altofonts")))
                                                             (* (SETQ INTERPRESSFONTDIRECTORIES
                                                           (CONS (PACK* ROOTDIRECTORY 
                                                           "/fonts/ipfonts"))))
    (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE))
    (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts")))
    (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT)
    (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL)
                (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL))    (* ; 
                  "Don't let the font loader substitute just because a server went catatonic on us")
               (for FAMILY in '(CLASSIC MODERN TERMINAL)
                  do (PRINTOUT T "  Loading " FAMILY " ")
                        [for SIZE in '(8 10 12)
                           do (PRINTOUT T SIZE " ")
                                 (for FACE in '(MRR BRR MIR)
                                    do 

                                          (* ;; "No need for Interpress")
                                                             (* (NLSETQ (FONTCREATE FAMILY SIZE 
                                                           FACE NIL (QUOTE INTERPRESS) NIL 0)))
                                          (for CSET
                                             in '(0 33 34 35 238 239 241)
                                             do (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL
                                                                   'DISPLAY NIL CSET]
                        (PRINTOUT T T))
               (PRINTOUT T "  Loading postscript fonts" T)
               (for F in (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES)
                                                ">c0>*.*")) do (PSCFONT.READFONT F))
               (PRINTOUT T "FULL fonts loaded" T])

(LOADNFS
  [LAMBDA NIL                                                (* ; 
                                                           "Edited 24-Aug-2020 20:38 by rmk:")
                                                             (* ; 
                                                           "Edited  8-Jun-94 14:20 by kaplan")
                                                             (* ; "Edited 16-Mar-90 14:07 by bbb")

(* ;;; "Function assumes that all directories are properly set")

(* ;;; "loads MINI-NFS and other related files")

    (* ;; "Moved UNIXCOMM, UNIXCHAT into the main MAKEFULLSYSOUT")

    (FILESLOAD (SYSLOAD FROM "{dsk}<project>medley3.5>nfs>")
           MINI-NFS)
    [COND
       (T                                                    (* ; 
                                       "Load Bill's patch to allow Sun users to refer to server/n.")
          (FILESLOAD (SYSLOAD)
                 UFSNFS))
       (T 
          (* ;; "Pray...")

          (\DEFINEDEVICE 'nfs 'dsk]
    (FILESLOAD (SYSLOAD FROM "{dsk}<project>medley3.5>nfs>")
           RPCOS)
    (FILESLOAD (SYSLOAD)
           RWALLSERVER NFSPROTECTION])

(MAKEFULLSYSOUT
  [LAMBDA NIL                                          (* ; "Edited 28-Nov-2020 16:55 by larry")
                                                             (* ; 
                                                           "Edited 14-May-2018 15:01 by kaplan")
                                                             (* ; 
                                                           "Edited 28-Sep-2020 12:35 by rmk:")
                                                             (* ; "Edited 17-Apr-2018 08:41 by ")
                                                             (* ; 
                                                           "Edited 21-Apr-2018 07:27 by rmk:")
                                                             (* ; "Edited 23-Feb-94 15:04 by bvm")
                                                             (* ; "Edited  2-Apr-90 14:42 by bbb")

(* ;;; "This file makes xfull35.sysout based on Venue's Lisp.sysout 3.5.  Start LISP.SYSOUT, connect to MEDLEYDIR for Lisp, connect to MEDLEYDIR/lispcore for lispcore.  Then load makefullsysout/MAKEFULLSYSOUT.LCOM.")

(* ;;; "If sysout looks good, copy to release (basics?)")

(* ;;; "")

    (CLRPROMPT)
    (CNDIR (UNIX-GETENV "LOADUPDIR"))
    (LET ((ROOTDIRECTORY (DIRECTORYNAME T)))                 (* ; 
                                                        "E.g. medley3.5/lisp or medley3.5/lispcore")
         (SETQ MAKESYSFILENAME (PACK* ROOTDIRECTORY "loadups/xfull35.sysout"))
                                                             (* ; "Should bind MAKESYSFILENAME")
         (DRIBBLE (PACKFILENAME 'EXTENSION 'dribble 'BODY MAKESYSFILENAME))

         (* ;; "BKSYSBUF stops page holding ")

         (PRINTOUT T T "Full loadup started at " (DATE)
                " while connected to "
                (DIRECTORYNAME T)
                T T)
         (BKSYSBUF " ")
         (SETQ DEFAULTFILETYPE 'BINARY)                      (* ; 
                                      "These prevent bits from being lost due to lack of knowledge")
         (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST)
                DEFAULTFILETYPELIST)                         (* (SETQ *UPPER-CASE-FILE-NAMES* NIL))
         (SETQ MAKESYSNAME :MEDLEY3.5)
         (PUSH DEFAULTFILETYPELIST '(TXT . TEXT)
                '(TEXT . TEXT)
                '(TEX . TEXT)
                '(HTML . TEXT)
                '(HTM . TEXT))
         (SETQ LISPSOURCEDIRECTORIES (LIST (PACK* ROOTDIRECTORY "sources")))
         (SETQ LISPUSERSDIRECTORIES (LIST (PACK* ROOTDIRECTORY "library")
                                          (PACK* ROOTDIRECTORY "lispusers")))
         (SETQ DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES DIRECTORIES))
         (SETQ LOADUPDIRECTORIES DIRECTORIES)

         (* ;; "(FILESLOAD (SYSLOAD FROM VALUEOF (PACK* ROOTDIRECTORY %"patches%")) FINDFONTPATCH)")

         (LOADUP '(POSTSCRIPTSTREAM))                        (* ; " to get PSCFONT.READFONT")
         (LOADFULLFONTS ROOTDIRECTORY)
         (LISTPUT IDLE.PROFILE 'TIMEOUT 0)
         (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)           (* ; "Skip DOSPRINT, assume only UNIX")
         (LOADUP '(CHAT NSCHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES 
                        GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT 
                        UNICODE ISO8859IO CLIPBOARD MACINTERFACE))

         (* ;; "Useful SSL stuff ")

         (AND NIL (FILESLOAD (SYSLOAD)
                         NSMAINTAIN NSPROTECTION))
         (FILESLOAD (SYSLOAD)
                PRETTYFILEINDEX WHO-LINE NSCOPYFILE)

         (* ;; "Turn off who-line until after the user has greeted")

         (CL:WHEN (WINDOWP *WHO-LINE*)
                (CLOSEW *WHO-LINE*))
         [SETQ POSTGREETFORMS (APPEND POSTGREETFORMS '((INSTALL-WHO-LINE-OPTIONS]
         (FILESLOAD (SYSLOAD)
                UNIXCOMM UNIXCHAT UNIXTELNET)
         (CL:WHEN NIL
             (FILESLOAD (SYSLOAD)
                    ARCHIVETOOL)
             (SETQ CH.DEFAULT.DOMAIN "PARC")
             (SETQ CH.DEFAULT.ORGANIZATION "XEROX")
             (LOADNFS)

             (* ;; "Load in the newest Lafite")

             (FILESLOAD (SYSLOAD)
                    LAFITE MIME LAFITE-INDENT NSMAIL NEWNSMAIL UNIXMAIL)
             (FILESLOAD (SYSLOAD)
                    SYSTEM33))
         (FILESLOAD (SYSLOAD)
                SETDEFAULTPRINTER)

         (* ;; "Load the patches last")

         (FILESLOAD (SYSLOAD)
                LOADPATCHES)
         (LoadPatches (PACK* ROOTDIRECTORY "patches>")
                'SYSLOAD NIL)

         (* ;; "Turn on Meta key for Dorados:  (METASHIFT T)")

         (\DAYTIME0 \LASTUSERACTION)
         (LISTPUT IDLE.PROFILE 'TIMEOUT 20)
         (FOR TYPE IN FILEPKTYPES DO (FILEPKGCHANGES TYPE NIL))
         (SETQ MAKESYSFILENAME (PACK* ROOTDIRECTORY "xfull35.sysout"))
         (SETTOPVAL 'INITIALS NIL)
         (PROMPTPRINT "About to end loadup")
         (PRINTOUT T "About to end loadup" T)

         (* ;; "From SYNCLISPFILES")

         (ENDLOADUP)
         (CL:WHEN LOGOW (CLOSEW LOGOW))
         (PUSH AFTERMAKESYSFORMS '(CLRPROMPT))

         (* ;; "Set up for making the sysout, if we made it this far.")

         (CL:WHEN WRITEFULLSYSOUTFLAG
             (PRINTOUT T "Creating FULL sysout on " MAKESYSFILENAME T)
             (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley " (MEDLEYVERSION)
                              " Full Sysout%")")))
         (DRIBBLE])

(PAGEHEIGHT
  [LAMBDA (N)                                          (* ; "Edited 20-Jul-88 10:13 by Burwell")

    (* ;; "sets the page height in lines of the screen.")

    (* ;; "20-Jul-88:  Took out the (SETQ \CURRENTDISPLAYLINE 0)")

    (PROG1 \#DISPLAYLINES
        (COND
           ((NUMBERP N)
            (SETQ \#DISPLAYLINES N))))])

(FIXMETA
  [LAMBDA NIL                                           (* ; "Edited 25-Jun-2017 17:12 by rmk:")
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
           \CURRENTKEYACTION)
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)

(FIXMETA)
(DEFINEQ

(LoadPatches
  [LAMBDA (DIRECTORY LDFLG AFTERDATE)                    (* ; "Edited  7-Feb-92 11:50 by bbb")

(* ;;; "Load all compiled files from the directory")

    (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*))
    (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS*
                          bind (AFTERIDATE _ (if AFTERDATE
                                                     then (OR (IDATE AFTERDATE)
                                                                  0)
                                                   else 0)) join (COLLECT-PATCH-FILES
                                                                          (DIRECTORYNAME DIRECTORY)
                                                                          EXT AFTERIDATE))
                       (FUNCTION (LAMBDA (X Y)
                                   (LESSP (CDR X)
                                          (CDR Y]            (* ; 
                                                           "files are sorted by increasing date")
         (for file in files do (SELECTQ LDFLG
                                               (HIDDEN       (* ; 
                                                       "Load the file, but don't put it on FILELST")
                                                       (LOAD? (CAR file)
                                                              T)
                                                       (SETQ FILELST (DREMOVE (FILENAMEFIELD
                                                                               (CAR file)
                                                                               'NAME)
                                                                            FILELST)))
                                               (LOAD? (CAR file)
                                                      LDFLG)))
         files])

(COLLECT-PATCH-FILES
  [LAMBDA (DIRECTORY EXT AFTERIDATE)                     (* ; "Edited  7-Feb-92 11:49 by bbb")

    (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE.  Return list of pairs (file . date).  Omits subdirectories.")

    (RESETLST
        (LET ((FILING.ENUMERATION.DEPTH 1)
              (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY))
              FILE DATE)
             (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";")
                                     '(ICREATIONDATE)
                                     '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN))
                when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY)
                                     NAKED-DIR)
                              (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE))
                                 AFTERIDATE)) collect (CONS FILE DATE))))])
)

(RPAQ? WRITEFULLSYSOUTFLAG T)

(RPAQQ COPYRIGHTFLG NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
)
(DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY 

(MAKEFULLSYSOUT)
)

(PUTPROPS MAKEFULLSYSOUT FILETYPE :TCOMPL)
(PUTPROPS MAKEFULLSYSOUT COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1061 11068 (LOADFULLFONTS 1071 . 3575) (LOADNFS 3577 . 4776) (MAKEFULLSYSOUT 4778 . 
10459) (PAGEHEIGHT 10461 . 10822) (FIXMETA 10824 . 11066)) (11084 14023 (LoadPatches 11094 . 13042) (
COLLECT-PATCH-FILES 13044 . 14021)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "29-Nov-2020 10:01:42" {DSK}<home>larry>ilisp>medley>makesysout>makefullsysout.;107 11923  

      changes to%:  (FNS MAKEFULLSYSOUT LOADFULLFONTS LOADNFS)
                    (COMMANDS "cd" "pwd" "ls")
                    (VARS MAKEFULLSYSOUTCOMS)

      previous date%: "28-Nov-2020 16:56:44" 
{DSK}<home>larry>ilisp>medley>makesysout>makefullsysout.;105)


(PRETTYCOMPRINT MAKEFULLSYSOUTCOMS)

(RPAQQ MAKEFULLSYSOUTCOMS
       ((COMMANDS "cd" "pwd" "ls")
        (FNS LOADFULLFONTS MAKEFULLSYSOUT FIXMETA)
        (P (FIXMETA))
        (FNS LoadPatches COLLECT-PATCH-FILES)
        (INITVARS (WRITEFULLSYSOUTFLAG T))
        (VARS (COPYRIGHTFLG NIL))
        (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
        (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAKEFULLSYSOUT)))
        (PROP FILETYPE MAKEFULLSYSOUT)))

(DEFCOMMAND "cd" (DIR) (/CNDIR DIR))

(DEFCOMMAND "pwd" NIL (DIRECTORYNAME T))

(DEFCOMMAND "ls" (FIRST . REST) (DODIR (CONS FIRST REST)))
(DEFINEQ

(LOADFULLFONTS
  [LAMBDA (ROOTDIRECTORY)                                    (* ; 
                                                           "Edited 11-Aug-2020 17:53 by rmk:")

    (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q")

    (PRINTOUT T "Loading FULL fonts..." T)
    (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts")
                                       (PACK* ROOTDIRECTORY "/fonts/altofonts")))
                                                             (* (SETQ INTERPRESSFONTDIRECTORIES
                                                           (CONS (PACK* ROOTDIRECTORY 
                                                           "/fonts/ipfonts"))))
    (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE))
    (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts")))
    (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT)
    (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL)
                (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL))    (* ; 
                  "Don't let the font loader substitute just because a server went catatonic on us")
               (for FAMILY in '(CLASSIC MODERN TERMINAL)
                  do (PRINTOUT T "  Loading " FAMILY " ")
                        [for SIZE in '(8 10 12)
                           do (PRINTOUT T SIZE " ")
                                 (for FACE in '(MRR BRR MIR)
                                    do 

                                          (* ;; "No need for Interpress")
                                                             (* (NLSETQ (FONTCREATE FAMILY SIZE 
                                                           FACE NIL (QUOTE INTERPRESS) NIL 0)))
                                          (for CSET
                                             in '(0 33 34 35 238 239 241)
                                             do (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL
                                                                   'DISPLAY NIL CSET]
                        (PRINTOUT T T))
               (PRINTOUT T "  Loading postscript fonts" T)
               (for F in (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES)
                                                ">c0>*.*")) do (PSCFONT.READFONT F))
               (PRINTOUT T "FULL fonts loaded" T])

(MAKEFULLSYSOUT
  [LAMBDA NIL                                          (* ; "Edited 29-Nov-2020 10:01 by larry")
                                                             (* ; 
                                                           "Edited 14-May-2018 15:01 by kaplan")
                                                             (* ; 
                                                           "Edited 28-Sep-2020 12:35 by rmk:")
                                                             (* ; "Edited 17-Apr-2018 08:41 by ")
                                                             (* ; 
                                                           "Edited 21-Apr-2018 07:27 by rmk:")
                                                             (* ; "Edited 23-Feb-94 15:04 by bvm")
                                                             (* ; "Edited  2-Apr-90 14:42 by bbb")

(* ;;; "This file makes xfull35.sysout based on Venue's Lisp.sysout 3.5.  Start LISP.SYSOUT, connect to MEDLEYDIR for Lisp, connect to MEDLEYDIR/lispcore for lispcore.  Then load makefullsysout/MAKEFULLSYSOUT.LCOM.")

(* ;;; "If sysout looks good, copy to release (basics?)")

(* ;;; "")

    (CLRPROMPT)
    (CNDIR (UNIX-GETENV "LOADUPDIR"))
    (LET ((ROOTDIRECTORY (DIRECTORYNAME T)))                 (* ; 
                                                        "E.g. medley3.5/lisp or medley3.5/lispcore")
         (SETQ MAKESYSFILENAME (PACK* ROOTDIRECTORY "loadups/xfull35.sysout"))
                                                             (* ; "Should bind MAKESYSFILENAME")
         (DRIBBLE (PACKFILENAME 'EXTENSION 'DRIBBLE 'BODY MAKESYSFILENAME))

         (* ;; "BKSYSBUF stops page holding ")

         (PRINTOUT T T "Full loadup started at " (DATE)
                " while connected to "
                (DIRECTORYNAME T)
                T T)
         (BKSYSBUF " ")
         (SETQ DEFAULTFILETYPE 'BINARY)                      (* ; 
                                      "These prevent bits from being lost due to lack of knowledge")
         (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST)
                DEFAULTFILETYPELIST)                         (* (SETQ *UPPER-CASE-FILE-NAMES* NIL))
         (SETQ MAKESYSNAME :MEDLEY3.5)
         (push DEFAULTFILETYPELIST '(TXT . TEXT)
                '(TEXT . TEXT)
                '(TEX . TEXT)
                '(HTML . TEXT)
                '(HTM . TEXT))
         (SETQ LISPSOURCEDIRECTORIES (LIST (PACK* ROOTDIRECTORY "sources")))
         (SETQ LISPUSERSDIRECTORIES (LIST (PACK* ROOTDIRECTORY "library")
                                          (PACK* ROOTDIRECTORY "lispusers")))
         (SETQ DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES DIRECTORIES))
         (SETQ LOADUPDIRECTORIES DIRECTORIES)
         (LOADUP '(POSTSCRIPTSTREAM))                        (* ; " to get PSCFONT.READFONT")
         (LOADFULLFONTS ROOTDIRECTORY)
         (LISTPUT IDLE.PROFILE 'TIMEOUT 0)
         (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
         (LOADUP '(CHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES GRAPHER SPY
                        WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT UNICODE HELPSYS 
                        DINFO CLIPBOARD MACINTERFACE))
         [NLSETQ (LOADUP '(ISO8859IO]
         (FILESLOAD (SYSLOAD)
                PRETTYFILEINDEX WHO-LINE)
         (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP))

         (* ;; "Turn off who-line until after the user has greeted")

         (CL:WHEN (WINDOWP *WHO-LINE*)
                (CLOSEW *WHO-LINE*))
         [SETQ POSTGREETFORMS (APPEND POSTGREETFORMS '((INSTALL-WHO-LINE-OPTIONS]
         (FILESLOAD (SYSLOAD)
                UNIXCOMM UNIXCHAT UNIXTELNET)
         (FILESLOAD (SYSLOAD)
                SETDEFAULTPRINTER)
         (FILESLOAD (SYSLOAD)
                LOADPATCHES)
         (\DAYTIME0 \LASTUSERACTION)
         (LISTPUT IDLE.PROFILE 'TIMEOUT 20)
         (for TYPE in FILEPKTYPES do (FILEPKGCHANGES TYPE NIL))
         (SETTOPVAL 'INITIALS NIL)
         (PROMPTPRINT "About to end loadup")
         (PRINTOUT T "About to end loadup" T)

         (* ;; "From SYNCLISPFILES")

         (ENDLOADUP)
         (CL:WHEN LOGOW (CLOSEW LOGOW))
         (push AFTERMAKESYSFORMS '(CLRPROMPT))

         (* ;; "Set up for making the sysout, if we made it this far.")

         (CL:WHEN WRITEFULLSYSOUTFLAG
             (PRINTOUT T "Creating FULL sysout on " MAKESYSFILENAME T)
             (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley " (MEDLEYVERSION)
                              " Full Sysout%")")))
         (DRIBBLE])

(FIXMETA
  [LAMBDA NIL                                           (* ; "Edited 25-Jun-2017 17:12 by rmk:")
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
           \CURRENTKEYACTION)
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)

(FIXMETA)
(DEFINEQ

(LoadPatches
  [LAMBDA (DIRECTORY LDFLG AFTERDATE)                    (* ; "Edited  7-Feb-92 11:50 by bbb")

(* ;;; "Load all compiled files from the directory")

    (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*))
    (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS*
                          bind (AFTERIDATE _ (if AFTERDATE
                                                     then (OR (IDATE AFTERDATE)
                                                                  0)
                                                   else 0)) join (COLLECT-PATCH-FILES
                                                                          (DIRECTORYNAME DIRECTORY)
                                                                          EXT AFTERIDATE))
                       (FUNCTION (LAMBDA (X Y)
                                   (LESSP (CDR X)
                                          (CDR Y]            (* ; 
                                                           "files are sorted by increasing date")
         (for file in files do (SELECTQ LDFLG
                                               (HIDDEN       (* ; 
                                                       "Load the file, but don't put it on FILELST")
                                                       (LOAD? (CAR file)
                                                              T)
                                                       (SETQ FILELST (DREMOVE (FILENAMEFIELD
                                                                               (CAR file)
                                                                               'NAME)
                                                                            FILELST)))
                                               (LOAD? (CAR file)
                                                      LDFLG)))
         files])

(COLLECT-PATCH-FILES
  [LAMBDA (DIRECTORY EXT AFTERIDATE)                     (* ; "Edited  7-Feb-92 11:49 by bbb")

    (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE.  Return list of pairs (file . date).  Omits subdirectories.")

    (RESETLST
        (LET ((FILING.ENUMERATION.DEPTH 1)
              (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY))
              FILE DATE)
             (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";")
                                     '(ICREATIONDATE)
                                     '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN))
                when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY)
                                     NAKED-DIR)
                              (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE))
                                 AFTERIDATE)) collect (CONS FILE DATE))))])
)

(RPAQ? WRITEFULLSYSOUTFLAG T)

(RPAQQ COPYRIGHTFLG NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
)
(DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY 

(MAKEFULLSYSOUT)
)

(PUTPROPS MAKEFULLSYSOUT FILETYPE :TCOMPL)
(PUTPROPS MAKEFULLSYSOUT COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1088 8597 (LOADFULLFONTS 1098 . 3602) (MAKEFULLSYSOUT 3604 . 8351) (FIXMETA 8353 . 8595
)) (8613 11552 (LoadPatches 8623 . 10571) (COLLECT-PATCH-FILES 10573 . 11550)))))
STOP
\ No newline at end of file
diff --git a/makesysout/makefullsysout.LCOM b/makesysout/makefullsysout.LCOM
index df4f73c5..b68efdfe 100644
Binary files a/makesysout/makefullsysout.LCOM and b/makesysout/makefullsysout.LCOM differ
