github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-03-13 22:19:30 +00:00
Code Issues Projects Releases Wiki Activity

These files cause the init.sysout to contain the :UTF-8 external format

Browse Source
This commit is contained in:
rmkaplan
2026-02-23 22:27:21 -08:00
parent 1bac4153e7
commit f8c0de913a
11 changed files with 3690 additions and 2158 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1508
library/UNICODE
View File

File diff suppressed because it is too large Load Diff

733
library/UNICODE-TABLES
View File

@@ -1,19 +1,22 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
(FILECREATED "22-Oct-2025 23:28:42" {WMEDLEY}<library>UNICODE-TABLES.;4 34028
(FILECREATED "22-Feb-2026 10:44:33" {WMEDLEY}<library>UNICODE-TABLES.;20 44960
:EDIT-BY rmk
:CHANGES-TO (VARS UNICODE-TABLESCOMS)
:CHANGES-TO (FNS ALL-UNICODE-MAPPINGS GET-MCCS-UNICODE-MAPPING INVERT-UNICODE-MAPPING
MAKE-UNICODE-TRANSLATION-TABLES MERGE-UNICODE-TRANSLATION-TABLES
READ-UNICODE-MAPPING-FILENAMES)
(VARS UNICODE-TABLESCOMS)
:PREVIOUS-DATE "16-Oct-2025 16:47:54" {WMEDLEY}<library>UNICODE-TABLES.;3)
:PREVIOUS-DATE "22-Feb-2026 09:15:20" {WMEDLEY}<library>UNICODE-TABLES.;16)
(PRETTYCOMPRINT UNICODE-TABLESCOMS)
(RPAQQ UNICODE-TABLESCOMS
[
(* ;; "Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence.")
(* ;; "This is code for reading/writing the XCCS-to-UNICODE mapping tables. It runs offline, when UNICODE-UTF8 is modified. ")
(COMS (* ; "Read Unicode mapping files")
(INITVARS (UNICODEDIRECTORIES NIL))
@@ -22,22 +25,32 @@
(FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING))
(COMS (* ;
 "Make translation tables for UTF external formats")
(FNS MAKE-UNICODE-TRANSLATION-TABLES XCCSTOMCCS-MAPPING
MERGE-UNICODE-TRANSLATION-TABLES UNICODE.UNMAPPED UNICODE-EXTEND-TRANSLATION?)
(FNS MAKE-UNICODE-TRANSLATION-TABLES GET-MCCS-UNICODE-MAPPING INVERT-UNICODE-MAPPING
XCCSTOMCCS-MAPPING)
(FNS ALL-UNICODE-MAPPINGS XCCSJAPANESECHARSETS)
(INITVARS (*MCCSTOUNICODE*)
(*UNICODETOMCCS*)
(*MCCS-LOADED-CHARSETS*)
(*UNICODE-LOADED-CHARSETS*)
(*LARGEUNICODES*))
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES 'ALL]
(COMS (* ; "Write Unicode mapping files")
(FNS WRITE-UNICODE-MAPPING WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER
WRITE-UNICODE-MAPPING-FILENAME)
(FNS XCCS-UTF8-AFTER-OPEN)
(* ;; "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))
(FNS UTF8HEXSTRING)
(COMS (* ; "debugging")
(FNS SHOWCHARS)
(DECLARE%: DOEVAL@LOAD DONTCOPY (MACROS HEXCHAR OCTALCHAR)))
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
UNICODE-EXPORTS])
(* ;;
"Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence."
"This is code for reading/writing the XCCS-to-UNICODE mapping tables. It runs offline, when UNICODE-UTF8 is modified. "
)
@@ -94,7 +107,8 @@
(DEFINEQ
(READ-UNICODE-MAPPING-FILENAMES
[LAMBDA (FILESPEC) (* ; "Edited 16-Oct-2025 16:43 by rmk")
[LAMBDA (FILESPEC) (* ; "Edited 21-Feb-2026 18:14 by rmk")
(* ; "Edited 16-Oct-2025 16:43 by rmk")
(* ; "Edited 4-Sep-2025 00:11 by rmk")
(* ; "Edited 27-Jan-2025 16:46 by rmk")
(* ; "Edited 21-Jan-2025 22:51 by rmk")
@@ -107,51 +121,47 @@
(* ;; "FILESPEC can be a file name, character-set name, the name of a collection of character sets, an XCCS character code, or a list of those. Maps those into the names of files that contain the indicated Unicode mappings.")
(CL:REMOVE-DUPLICATES [for F X CSI inside (if (EQ FILESPEC 'ALL)
then
(* ;;
(for F X CSI inside (if (EQ FILESPEC 'ALL)
then
(* ;;
 "Perhaps should figure out which files in the directories and subdirectories are relevant?")
(for N in XCCS-CHARSETS
collect (CAR N))
else FILESPEC)
join
(* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)")
(for N in XCCS-CHARSETS collect (CAR N))
else FILESPEC)
join
(* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)")
(OR (CL:WHEN (CHARCODEP F) (* ;
[OR (CL:WHEN (CHARCODEP F) (* ;
 "An XCCS code can retrieve its character set")
(for D FN (FOCTAL _ (OCTALSTRING (LRSH F 8))) inside
UNICODEDIRECTORIES
when (SETQ FN (FILDIR (PACKFILENAME 'DIRECTORY D
'BODY
(CONCAT 'XCCS- FOCTAL
'=*)
'EXTENSION
'TXT
'VERSION "")))
do (RETURN FN)))
(MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT
'VERSION "")
T UNICODEDIRECTORIES))
(for D inside UNICODEDIRECTORIES
when [SETQ $$VAL (OR (FILDIR (PACKFILENAME 'NAME
(CONCAT "XCCS-*=" F)
'EXTENSION
'TXT
'VERSION "" 'BODY D))
(FILDIR (PACKFILENAME 'NAME
(CONCAT "XCCS-" F "=*")
'EXTENSION
'TXT
'VERSION "" 'BODY D]
do (RETURN $$VAL))
(AND (SETQ CSI (ASSOC F XCCS-CHARSETS))
(READ-UNICODE-MAPPING-FILENAMES (CDR CSI)))
(for D inside UNICODEDIRECTORIES
when (DIRECTORYNAMEP (SETQ D (CONCAT D ">" F ">")))
join (FILDIR (CONCAT D ">*.TXT;"]
:TEST
(FUNCTION STRING.EQUAL])
(for D FN (FOCTAL ← (OCTALSTRING (LRSH F 8))) inside UNICODEDIRECTORIES
when (SETQ FN (DIRECTORY (PACKFILENAME 'DIRECTORY D 'BODY (CONCAT 'XCCS-
FOCTAL
'=*)
'EXTENSION
'TXT
'VERSION ""))) do (RETURN FN)))
(MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT 'VERSION "")
T UNICODEDIRECTORIES))
(for D inside UNICODEDIRECTORIES
when [SETQ $$VAL (OR (DIRECTORY (PACKFILENAME 'NAME (CONCAT "XCCS-*=" F)
'EXTENSION
'TXT
'VERSION "" 'BODY D))
(DIRECTORY (PACKFILENAME 'NAME (CONCAT "XCCS-" F "=*")
'EXTENSION
'TXT
'VERSION "" 'BODY D]
do (RETURN $$VAL))
(AND (SETQ CSI (ASSOC F XCCS-CHARSETS))
(READ-UNICODE-MAPPING-FILENAMES (CDR CSI)))
(for D inside UNICODEDIRECTORIES when (DIRECTORYNAMEP (SETQ D
(CONCAT D ">" F ">")))
join (DIRECTORY (CONCAT D ">*.TXT;"]
finally (* ;
 "CL:REMOVE-DUPLICATES doesn't exist in MAKEINIT")
(RETURN (for FTAIL on $$VAL unless (thereis FF in (CDR FTAIL)
suchthat (STRING-EQUAL (CAR FTAIL)
FF)) collect (CAR FTAIL])
(READ-UNICODE-MAPPING
[LAMBDA (FILESPEC PRINT NOERROR) (* ; "Edited 16-Oct-2025 11:25 by rmk")
@@ -179,7 +189,7 @@
(* ;; "")
(RESETLST
(for FILE STREAM [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] in (
(for FILE STREAM [SEPBITTABLE ← (MAKEBITTABLE (CHARCODE (TAB SPACE] in (
 READ-UNICODE-MAPPING-FILENAMES
FILESPEC)
join
@@ -221,7 +231,8 @@
(DEFINEQ
(MAKE-UNICODE-TRANSLATION-TABLES
[LAMBDA (MAPPING REINSTALL) (* ; "Edited 11-Oct-2025 11:54 by rmk")
[LAMBDA (MAPPING REINSTALL) (* ; "Edited 21-Feb-2026 22:42 by rmk")
(* ; "Edited 11-Oct-2025 11:54 by rmk")
(* ; "Edited 4-Sep-2025 00:30 by rmk")
(* ; "Edited 24-Apr-2025 15:47 by rmk")
(* ; "Edited 31-Jan-2025 17:46 by rmk")
@@ -232,26 +243,13 @@
(* ; "Edited 3-Feb-2024 00:24 by rmk")
(* ; "Edited 30-Jan-2024 09:54 by rmk")
(* ; "Edited 21-Aug-2021 13:12 by rmk:")
(SETQ MAPPING (GET-MCCS-UNICODE-MAPPING MAPPING))
(* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to XCCS-to-Unicode mapping files. This applies the XCCS-to-MCCS translations, and then updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).")
 (* ; "Edited 17-Aug-2020 08:46 by rmk:")
(CL:UNLESS [AND (LISTP MAPPING)
(FOR PAIR R IN MAPPING AS I TO 10
ALWAYS (AND (LISTP PAIR)
(CHARCODEP (CAR PAIR))
[FIXP (SETQ R (CAR (MKLIST (CADR PAIR]
(CHARCODEP (IABS R]
(* ;; "Seems like the argument is not already a list of mapping pairs (perhaps with a combiner), presumably a list of charsets to be read.")
(SETQ MAPPING (READ-UNICODE-MAPPING MAPPING)))
(SETQ MAPPING (XCCSTOMCCS-MAPPING MAPPING))
(* ;; "This updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).")
(* ;; "This updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).")
(* ;; "")
(* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *XCCSTOUNICODE* and *UNICODETOXCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).")
(* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *MCCSTOUNICODE* and *UNICODETOMCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).")
(* ;; "")
@@ -270,6 +268,55 @@
(SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE))
(MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING])
(GET-MCCS-UNICODE-MAPPING
[LAMBDA (MAPPING) (* ; "Edited 22-Feb-2026 00:29 by rmk")
(* ;; "MAPPING is the list of numeric code correspondence pairs mapping MCCS-to-Unicode, or a specification of XCCS-to-Unicode files to be read and converted to MCCS-to-UNICODE.")
(SORT (if [AND (LISTP MAPPING)
(for PAIR R in MAPPING as I to 10
always (AND (LISTP PAIR)
(CHARCODEP (CAR PAIR))
[FIXP (SETQ R (CAR (MKLIST (CADR PAIR]
(CHARCODEP (IABS R]
then
(* ;; "The argument is already a list of MCCS-to-UNICODE mapping pairs")
MAPPING
else
(* ;; "Mapping files are is read as XCCS-UNICODE, make it MCCS")
(XCCSTOMCCS-MAPPING (READ-UNICODE-MAPPING MAPPING)))
T])
(INVERT-UNICODE-MAPPING
[LAMBDA (MAPPING) (* ; "Edited 22-Feb-2026 00:39 by rmk")
(* ;; "MAPPING is a list of pairs that map domain codes to range codes (presumably MCCS to UNICODE). This produces an inverted list of pairs that map the range into the domain (Unicode to MCCS) ")
(LET (INVERTED)
(SETQ INVERTED (SORT (for P D R OLDR in MAPPING eachtime (SETQ D (CAR P))
(SETQ R (CADR P))
(* ;;
 "We don't do combiners, but we are allowing non-SMALLP's")
unless (OR (LISTP D)
(LISTP R)) collect (LIST R D))
T))
(* ;; "If MAPPING contains two pairs that map to the same U (e.g. (M1 U) and (M2 U)), we want the inverse table to collect them into a single pair (U M1 M2) instead of two pairs (U M1) (U M2), with the lowest M code first. Those pairs represent alternative inverse mappings. There are no duplicates/alternative table entries in the M-to-U direction.")
(* ;; "The SORT above means that multiple inverted pairs for the same U will be next to each other in the list.")
[for PTAIL PTAIL2 U MS on INVERTED eachtime (SETQ U (CAAR PTAIL))
when (SETQ MS (for old PTAIL2 P2 on PTAIL eachtime (SETQ P2 (CADR PTAIL2))
while (EQ U (CAR P2)) collect (CADR P2)))
do (RPLACD PTAIL (CDR PTAIL2))
(RPLACD (CAR PTAIL)
(SORT (CONS (CADR (CAR PTAIL))
MS]
INVERTED])
(XCCSTOMCCS-MAPPING
[LAMBDA (XTOUMAPPING) (* ; "Edited 11-Oct-2025 12:57 by rmk")
@@ -292,152 +339,12 @@
XTOMCODES)))
finally (push XTOUMAPPING (CHARCODE (DEL DEL)))
(RETURN XTOUMAPPING])
(MERGE-UNICODE-TRANSLATION-TABLES
[LAMBDA (INVERSE MAPPING TABLE INVERSETABLE) (* ; "Edited 11-Oct-2025 10:24 by rmk")
(* ; "Edited 24-Apr-2025 15:28 by rmk")
(* ; "Edited 1-Feb-2025 21:42 by rmk")
(* ; "Edited 26-Jan-2025 12:58 by rmk")
(* ; "Edited 22-Jan-2025 08:20 by rmk")
(* ; "Edited 19-Jan-2025 15:58 by rmk")
(* ; "Edited 18-Jan-2025 11:49 by rmk")
(* ; "Edited 27-Mar-2024 12:10 by rmk")
(* ; "Edited 3-Feb-2024 12:46 by rmk")
(* ; "Edited 31-Jan-2024 10:06 by rmk")
(* ;; "MAPPINGS is a list of pairs that map domain codes to range codes. TABLE and INVERSETABLE default to *MCCSTOUNICODE* *UNICODETOMCCS* respectively. ")
(CL:UNLESS TABLE
[SETQ TABLE (OR *MCCSTOUNICODE* (SETQ *MCCSTOUNICODE* (HASHARRAY (LENGTH MAPPING])
(CL:UNLESS INVERSETABLE
[SETQ INVERSETABLE (OR *UNICODETOMCCS* (SETQ *UNICODETOMCCS* (HASHARRAY (LENGTH MAPPING])
(for M D R OLDR in MAPPING first (CL:IF INVERSE (swap TABLE INVERSETABLE))
eachtime (SETQ D (CAR M))
(SETQ R (CADR M))
(* ;; "We don't do combiners, but we are allowing non-SMALLP's")
unless (OR (LISTP D)
(LISTP R)) do
(* ;; "The (CONS R OLDR) deals with alternatives: (U X1) (U X2) => (U (X1 X2)), lowest code first. Those are only possible in the U-to-X direction when the tables contain (X1 U) and (X2 U). There are no duplicates/alternative table entries in the X-to-U direction.")
(SETQ OLDR (GETHASH D TABLE))
(CL:UNLESS (MEMB R OLDR)
(PUTHASH D (SORT (CONS R OLDR))
TABLE))
(swap D R)
(SETQ OLDR (GETHASH D INVERSETABLE))
(CL:UNLESS (MEMB R OLDR)
(PUTHASH D (SORT (CONS R OLDR))
INVERSETABLE)))
(LIST TABLE INVERSETABLE])
(UNICODE.UNMAPPED
[LAMBDA (CODE TABLE DONTFAKE) (* ; "Edited 24-Apr-2025 15:48 by rmk")
(* ; "Edited 22-Jan-2025 08:19 by rmk")
(* ; "Edited 19-Jan-2025 22:02 by rmk")
(* ; "Edited 18-Jan-2025 12:02 by rmk")
(* ; "Edited 2-Feb-2024 23:52 by rmk")
(* ; "Edited 31-Jan-2024 10:07 by rmk")
(* ; "Edited 11-Aug-2020 20:23 by rmk:")
(* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODE has no fast mapping in TRANSLATION-TABLE.")
(* ;; "")
(* ;; "If we have not already installed the mapping segment for that code, we try to retrieve it from the numberic file. If that segment mapping doesn't exist or doesn't have an entry for CODE, we fake up a mapping with a negative range in both directions. One way or the other, there will be an entry for that segment in both mapping vectors.")
(* ;; "")
(PROG ((INVERSE (EQ TABLE *UNICODETOMCCS*))
RANGE HASH)
(* ;; "If we already looked up CODE's character set in a file, then we have already filled in its information in the translation table. If it didn't have a code for a particular character, then we fake it here. Faked codes are negative, so we can detect them easily, and interpret them with IABS.")
(CL:WHEN (AND (UNICODE-EXTEND-TRANSLATION? CODE TABLE)
(SETQ RANGE (GETHASH CODE TABLE)))
(* ;; "We might have gotten the segment that didn't have an entry for CODE.")
(RETURN RANGE))
(* ;; "")
(CL:UNLESS DONTFAKE
(* ;; "Our attempt at extending the known tables did not provide a mapping for CODE. So we fake it up with the next unused private code in the code space. ")
(* ;; "The number of possible faked mappings is determined by the number of private-use Unicodes, since the MCCS character space is pretty sparse. The codes don't have to come from the same part of the code space, and the NEXTCODEs are saved in global variables. The last available codes are constants.")
(CL:WHEN (IEQP *NEXT-PRIVATE-MCCSCODE* LAST-PRIVATE-MCCSCODE)
(* ;
 "Same number of available codes both ways")
(ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES"))
(if INVERSE
then (SETQ RANGE *NEXT-PRIVATE-MCCSCODE*)
(add *NEXT-PRIVATE-MCCSCODE* 1)
else (SETQ RANGE *NEXT-PRIVATE-UNICODE*)
(add *NEXT-PRIVATE-UNICODE* 1))
(MERGE-UNICODE-TRANSLATION-TABLES INVERSE (CONS (LIST CODE RANGE)))
(* ;; "CONS because of LIST convention so we can eventually distinguish combiners.")
(RETURN (CONS RANGE)))])
(UNICODE-EXTEND-TRANSLATION?
[LAMBDA (CODE TABLE) (* ; "Edited 11-Oct-2025 09:49 by rmk")
(* ; "Edited 4-Sep-2025 00:34 by rmk")
(* ; "Edited 29-Jun-2025 16:44 by rmk")
(* ; "Edited 24-Apr-2025 15:49 by rmk")
(* ; "Edited 26-Jan-2025 11:26 by rmk")
(* ; "Edited 21-Jan-2025 22:31 by rmk")
(* ; "Edited 18-Jan-2025 12:40 by rmk")
(* ; "Edited 13-Jan-2025 23:50 by rmk")
(* ; "Edited 26-Aug-2024 16:49 by rmk")
(* ; "Edited 27-Mar-2024 23:02 by rmk")
(* ; "Edited 5-Feb-2024 13:48 by rmk")
(* ; "Edited 3-Feb-2024 12:40 by rmk")
(* ;; "There is currently no mapping for CODE in TABLE, hopefully just because the relevant character-set mapping has not been installed. We infer from TABLE whether CODE is an MCCS or UNICODE code and look for the proper mapping table (forward or inverted) for its character set. ")
(* ;; "We record which character sets we have already expanded so we don't do them again.")
(LET ((CHARSET (\CHARSET CODE))
(INVERSE (EQ TABLE *UNICODETOMCCS*))
MAPPING FILE)
(* ;; "If we already looked for CHARSET in the file and found anything, it has already been merged. Otherwise, it would just fail again")
(CL:UNLESS (MEMB CHARSET (CL:IF INVERSE
*UNICODE-LOADED-CHARSETS*
*MCCS-LOADED-CHARSETS*))
(* ;; "Don't try this charset again.")
(CL:IF INVERSE
(push *UNICODE-LOADED-CHARSETS* CHARSET)
(push *MCCS-LOADED-CHARSETS* CHARSET))
(SETQ FILE (FINDFILE (CL:IF INVERSE
'UNICODE-TO-MCCS-MAPPINGS
'MCCS-TO-UNICODE-MAPPINGS)
T UNICODEDIRECTORIES))
(* ;; "The mappings files are indexed by CHARSET.")
(CL:WHEN [AND FILE (SETQ MAPPING (CL:WITH-OPEN-FILE (STREAM FILE :INPUT)
(CL:WHEN (FILEPOS (CONCAT "[" CHARSET " ")
STREAM NIL NIL NIL T)
(READ STREAM]
(* ;;
 "Merge MAPPING into both tables, respecting the direction indicated by TABLE. ")
(MERGE-UNICODE-TRANSLATION-TABLES INVERSE MAPPING)
T))])
)
(DEFINEQ
(ALL-UNICODE-MAPPINGS
[LAMBDA (INVERTED FILE) (* ; "Edited 24-Apr-2025 15:51 by rmk")
[LAMBDA (INVERTED FILE) (* ; "Edited 22-Feb-2026 10:42 by rmk")
(* ; "Edited 24-Apr-2025 15:51 by rmk")
(* ; "Edited 31-Jan-2025 17:46 by rmk")
(* ; "Edited 26-Jan-2025 13:40 by rmk")
(* ; "Edited 22-Jan-2025 14:07 by rmk")
@@ -453,38 +360,32 @@
(* ;; "The first index level segments all the domain codes according to their character sets. The segments are sorted by character set, the pairs within each segment are sorted by their domain codes. ")
(* ;;
 "E.g. if INVERTED=NIL and given a XCCS code, the lookup for the corresponding Unicode(s) is")
 "E.g. if INVERTED=NIL and given a MCCS code, the lookup for the corresponding Unicode(s) is")
(* ;; " (CADR (ASSOC MCCSCODE (\CHARSET MCCSCODE) INDEX)))).")
(* ;; " (CAR (GETMULTI INDEX (\CHARSET MCCSCODE) MCCSCODE).")
(* ;; "If FILE is not NIL, the result is written to a file. If FILE is T, the file is either MCCS-TO-UNICODE-MAPPINGS.TXT or UNICODE-TO-MCCS-MAPPINGS.TXT, depending on INVERTED.")
(LET (INDEX)
(for PAIR DOMAIN RANGE CHARSET in (READ-UNICODE-MAPPING 'ALL) eachtime (SETQ DOMAIN
(CAR PAIR))
(SETQ RANGE (CADR PAIR))
(* ;;
 "(LISTP RANGE) is a combiner, ignored for now.")
unless (LISTP RANGE) do (CL:WHEN INVERTED (SWAP DOMAIN RANGE))
(LET [INDEX (MAPPING (GET-MCCS-UNICODE-MAPPING 'ALL]
(for PAIR in (CL:IF INVERTED
(INVERT-UNICODE-MAPPING MAPPING)
MAPPING) unless (LISTP (CADR PAIR)) do
(* ;;
 "(LISTP (CADR PAIR) is a combiner, ignored for now.")
(* ;;
(* ;;
 "One segment for each high-byte character set. This aligns with UNICODE-EXTEND.TRANSLATION?")
[SETQ CHARSET (OR (ASSOC (\CHARSET DOMAIN)
INDEX)
(CAR (push INDEX (CONS (\CHARSET DOMAIN]
(* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CAR (GETMULTI)) is the first (and almost always) the only one.")
(* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CADR is the first (and almost always) the only one.")
(pushnew [CDR (OR (ASSOC DOMAIN (CDR CHARSET))
(CAR (push (CDR CHARSET)
(CONS DOMAIN]
RANGE))
(PUSHMULTI-NEW INDEX
(\CHARSET (CAR PAIR))
(CAR PAIR)
(CADR PAIR)))
(* ;; "Push the charset mappings down an extra CONS, so that a subsequent READ will get them all after a FILEPOS search for super-paren [")
[for CS in INDEX do (for M in (CDR CS) when (CDDR M) do
(for CS in INDEX do (for M in (CDR CS) when (CDDR M) do
(* ;;
 "Sort the range alternatives, if any")
@@ -494,7 +395,7 @@
(* ;; "Sort by domain codes and push down a level")
(change (CDR CS)
(CONS (SORT DATUM T]
(SORT DATUM T)))
(SETQ INDEX (SORT INDEX T)) (* ; "Sort character sets")
(if FILE
then (SETQ FILE (PACKFILENAME 'BODY (if (NEQ FILE T)
@@ -544,18 +445,347 @@
(FULLNAME STREAM))))])
)
(RPAQ? *MCCSTOUNICODE* )
(RPAQ? *UNICODETOMCCS* )
(RPAQ? *MCCS-LOADED-CHARSETS* )
(* ; "Write Unicode mapping files")
(RPAQ? *UNICODE-LOADED-CHARSETS* )
(DEFINEQ
(RPAQ? *LARGEUNICODES* )
(DECLARE%: DONTEVAL@LOAD DOCOPY
(WRITE-UNICODE-MAPPING
[LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 4-Jan-2024 22:44 by rmk")
(* ; "Edited 16-Aug-2020 16:56 by rmk:")
(MAKE-UNICODE-TRANSLATION-TABLES 'ALL)
(* ;; "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 :UTF-8-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 5-Jan-2024 13:24 by rmk")
(* ; "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 " "))
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])
)
(DEFINEQ
(XCCS-UTF8-AFTER-OPEN
[LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 3-Jan-2024 10:27 by rmk")
(* ; "Edited 13-Aug-2020 11:54 by rmk:")
(* ;;
 "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF-8. For development")
(CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM)))
[EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM)
'EXTENSION]
(NOT (ASSOC 'EXTERNALFORMAT PARAMETERS)))
(STREAMPROP STREAM 'EXTERNALFORMAT :UTF-8))])
)
(* ;; "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 (Version 2.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"
"2.0, 1990) into Unicode 3.0. standard codes. That is an extension of 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 and the Unicode character names when 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 UTF-8, 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>"))
(DEFINEQ
(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])
)
(* ; "debugging")
(DEFINEQ
(SHOWCHARS
[LAMBDA (FONT FROMCHAR TOCHAR ONELINE) (* ; "Edited 5-Oct-2025 17:41 by rmk")
(* ; "Edited 7-Sep-2025 20:29 by rmk")
(* ; "Edited 2-Sep-2025 10:26 by rmk")
(* ; "Edited 24-Jul-2025 11:30 by rmk")
(* ; "Edited 8-Jun-2025 20:05 by rmk")
(* ; "Edited 26-Jan-2024 14:18 by mth")
(* ; "Edited 1-Aug-2020 09:27 by rmk:")
[SETQ FONT (FONTCREATE (OR FONT '(CLASSIC 12]
(RESETLST
[LET ((OLDFONT (DSPFONT NIL T))
CHARS)
(CL:UNLESS (CHARCODEP FROMCHAR)
(SETQ FROMCHAR (OR (CHARCODE.DECODE FROMCHAR T)
FROMCHAR)))
(SETQ CHARS (if (LISTP FROMCHAR)
elseif (CHARCODEP FROMCHAR)
then (CL:UNLESS (CHARCODEP TOCHAR)
(SETQ TOCHAR (OR (CHARCODE.DECODE TOCHAR)
FROMCHAR)))
(for C from FROMCHAR to TOCHAR collect C)
else (CHCON FROMCHAR)))
[RESETSAVE OLDFONT '(PROGN (DSPFONT OLDVALUE]
(TERPRI)
(for C in CHARS do (PRINTOUT T .FONT OLDFONT (CONCAT (OCTALSTRING (\CHARSET C))
","
(OCTALSTRING (\CHAR8CODE C)))
10 .FONT FONT (CHARACTER C))
(CL:UNLESS ONELINE (PRINTOUT T T])
(TERPRI])
)
(DECLARE%: DOEVAL@LOAD DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS HEXCHAR MACRO ((CODE)
(HEXSTRING CODE)))
(PUTPROPS OCTALCHAR MACRO [(CODE)
(CONCAT (OCTALSTRING (\CHARSET CODE))
","
(OCTALSTRING (LOGAND CODE 255])
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
@@ -563,9 +793,12 @@
UNICODE-EXPORTS)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3341 12542 (READ-UNICODE-MAPPING-FILENAMES 3351 . 8301) (READ-UNICODE-MAPPING 8303 .
12540)) (12609 26839 (MAKE-UNICODE-TRANSLATION-TABLES 12619 . 16379) (XCCSTOMCCS-MAPPING 16381 . 17598
) (MERGE-UNICODE-TRANSLATION-TABLES 17600 . 20253) (UNICODE.UNMAPPED 20255 . 23579) (
UNICODE-EXTEND-TRANSLATION? 23581 . 26837)) (26840 33676 (ALL-UNICODE-MAPPINGS 26850 . 32339) (
XCCSJAPANESECHARSETS 32341 . 33674)))))
(FILEMAP (NIL (4107 12829 (READ-UNICODE-MAPPING-FILENAMES 4117 . 8586) (READ-UNICODE-MAPPING 8588 .
12827)) (12896 19704 (MAKE-UNICODE-TRANSLATION-TABLES 12906 . 15666) (GET-MCCS-UNICODE-MAPPING 15668
. 16688) (INVERT-UNICODE-MAPPING 16690 . 18483) (XCCSTOMCCS-MAPPING 18485 . 19702)) (19705 26328 (
ALL-UNICODE-MAPPINGS 19715 . 24991) (XCCSJAPANESECHARSETS 24993 . 26326)) (26373 37135 (
WRITE-UNICODE-MAPPING 26383 . 30127) (WRITE-UNICODE-INCLUDED 30129 . 34441) (
WRITE-UNICODE-MAPPING-HEADER 34443 . 35691) (WRITE-UNICODE-MAPPING-FILENAME 35693 . 37133)) (37136
37812 (XCCS-UTF8-AFTER-OPEN 37146 . 37810)) (40337 42426 (UTF8HEXSTRING 40347 . 42424)) (42453 44495 (
SHOWCHARS 42463 . 44493)))))
STOP

BIN
library/UNICODE-TABLES.LCOM
View File

Binary file not shown.

BIN
library/UNICODE.LCOM
View File

Binary file not shown.

195
sources/EXTERNALFORMAT
View File

@@ -1,10 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
(FILECREATED "20-Feb-2026 09:18:35" {WMEDLEY}<sources>EXTERNALFORMAT.;123 51558
(FILECREATED "22-Feb-2026 12:29:38" {WMEDLEY}<sources>EXTERNALFORMAT.;124 45411
:EDIT-BY rmk
:PREVIOUS-DATE "19-Feb-2026 13:32:00" {WMEDLEY}<sources>EXTERNALFORMAT.;122)
:CHANGES-TO (VARS EXTERNALFORMATCOMS)
:PREVIOUS-DATE "20-Feb-2026 09:18:35" {WMEDLEY}<sources>EXTERNALFORMAT.;123)
(PRETTYCOMPRINT EXTERNALFORMATCOMS)
@@ -35,13 +37,6 @@
[COMS (* ; "NULL device, from FILEIO")
(FNS \NULLDEVICE \NULL.OPENFILE)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\NULLDEVICE]
[COMS (* ; "ISO8859/1")
(FNS ISO1TOMCODE MTOISO1CODE \CREATE.ISO1.FORMAT \DUMMY-UTF8-FORMAT)
(FNS ISO1TOMSTRING MTOISO1STRING)
(VARS ISO1TOMCCS)
(GLOBALVARS ISO1TOMCCS)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.ISO1.FORMAT)
(\DUMMY-UTF8-FORMAT]
(COMS
(* ;; "Also from FILEIO.")
@@ -736,166 +731,6 @@
(* ; "ISO8859/1")
(DEFINEQ
(ISO1TOMCODE
[LAMBDA (ICODE) (* ; "Edited 5-Feb-2026 12:09 by rmk")
(* ; "Edited 2-Feb-2026 23:14 by rmk")
(* ; "Edited 7-Sep-2025 22:39 by rmk")
(* ; "Edited 3-Sep-2025 10:21 by rmk")
(* ; "Edited 7-Aug-2025 09:37 by rmk")
(* ;; "ISO codes are 8bit, MCODES maybe not. Caller shouldn't pass a fat code.")
(OR [CAR (find PAIR in ISO1TOMCCS suchthat (EQ ICODE (CADR PAIR]
ICODE])
(MTOISO1CODE
[LAMBDA (MCODE) (* ; "Edited 5-Feb-2026 12:26 by rmk")
(* ; "Edited 2-Feb-2026 22:58 by rmk")
(OR (CADR (ASSOC MCODE ISO1TOMCCS))
MCODE])
(\CREATE.ISO1.FORMAT
[LAMBDA NIL (* ; "Edited 5-Feb-2026 10:42 by rmk")
(* ; "Edited 2-Feb-2026 23:37 by rmk")
(* ; "Edited 1-Feb-2026 11:18 by rmk")
(* ; "Edited 5-Aug-2021 22:15 by rmk:")
(* ; "Edited 9-Mar-99 17:19 by rmk:")
(* ; "Edited 7-Dec-95 16:24 by ")
(* ; "Edited 7-Dec-95 16:20 by ")
(MAKE-EXTERNALFORMAT :ISO8859/1 [FUNCTION (LAMBDA (STREAM COUNTP)
(ISO1TOMCODE (\THROUGHIN STREAM COUNTP]
[FUNCTION (LAMBDA (STREAM NOERRORFLG)
(ISO1TOMCODE (\PEEKBIN STREAM NOERRORFLG]
(FUNCTION \THROUGHBACKCCODE)
(FUNCTION NILL)
(FUNCTION NILL)
NIL NIL (FUNCTION MTOISO1STRING)
NIL
(FUNCTION NILL)
(FUNCTION ISO1TOMSTRING])
(\DUMMY-UTF8-FORMAT
[LAMBDA NIL (* ; "Edited 5-Feb-2026 15:58 by rmk")
(* ; "Edited 1-Feb-2026 13:16 by rmk")
(* ;; "Works only for 7-bit codes, during the loadup")
(\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT using (FIND-FORMAT :ISO8859/1)
NAME ← :UTF-8])
)
(DEFINEQ
(ISO1TOMSTRING
[LAMBDA (ISTRING DESTRUCTIVE) (* ; "Edited 5-Feb-2026 11:01 by rmk")
(* ; "Edited 2-Feb-2026 23:46 by rmk")
(* ; "Edited 2-Sep-2025 12:14 by rmk")
(* ; "Edited 29-Apr-2025 13:08 by rmk")
(* ;; "Converts ISO8859/1 codes to MCCS codes in MSTRING.")
(for I ICODE (MSTRING ← (CL:IF DESTRUCTIVE
ISTRING
(CONCAT ISTRING))) from 1 while (SETQ ICODE (NTHCHARCODE ISTRING I))
do (RPLCHARCODE MSTRING I (ISO1TOMCODE ICODE)) finally (RETURN MSTRING])
(MTOISO1STRING
[LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 2-Feb-2026 23:47 by rmk")
(* ; "Edited 2-Sep-2025 12:22 by rmk")
(* ; "Edited 29-Apr-2025 13:08 by rmk")
(* ;; "Converts MCCS to ISO8859/1 codes in MSTRING.")
(for I MCODE (ISTRING ← (CL:IF DESTRUCTIVE
MSTRING
(CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I))
do (RPLCHARCODE ISTRING I (MTOISO1CODE MCODE)) finally (RETURN ISTRING])
)
(RPAQQ ISO1TOMCCS
((94 8593)
(95 8592)
(169 8216)
(170 8220)
(172 95)
(173 94)
(174 8594)
(175 8595)
(180 215)
(184 247)
(185 8217)
(186 8221)
(193 768)
(194 769)
(195 770)
(196 771)
(197 772)
(198 774)
(199 775)
(200 776)
(202 778)
(203 807)
(204 818)
(205 779)
(206 808)
(207 780)
(208 8213)
(209 185)
(210 174)
(211 169)
(212 8482)
(213 9834)
(220 8539)
(221 8540)
(222 8541)
(223 8542)
(224 8486)
(225 198)
(226 208)
(227 170)
(228 294)
(229 567)
(230 306)
(231 319)
(232 321)
(233 216)
(234 338)
(235 186)
(236 222)
(237 358)
(238 330)
(239 329)
(240 312)
(241 230)
(242 273)
(243 240)
(244 295)
(245 305)
(246 307)
(247 320)
(248 322)
(249 248)
(250 339)
(251 223)
(252 254)
(253 359)
(254 331)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS ISO1TOMCCS)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(\CREATE.ISO1.FORMAT)
(\DUMMY-UTF8-FORMAT)
)
(* ;; "Also from FILEIO.")
(DEFINEQ
@@ -1006,16 +841,14 @@
(\CREATE.THROUGH16.EXTERNALFORMAT)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (7548 15469 (\EXTERNALFORMAT 7558 . 12157) (MAKE-EXTERNALFORMAT 12159 . 14996) (
\EXTERNALFORMAT.DEFPRINT 14998 . 15467)) (15470 18335 (\INSTALL.EXTERNALFORMAT 15480 . 16837) (
\REMOVE.EXTERNALFORMAT 16839 . 17586) (FIND-FORMAT 17588 . 18333)) (18753 33028 (\OUTCHAR 18763 .
19980) (\INCCODE 19982 . 21135) (\BACKCCODE 21137 . 22816) (\BACKCCODE.EOLC 22818 . 25008) (\PEEKCCODE
25010 . 25335) (\PEEKCCODE.EOLC 25337 . 25716) (\INCCODE.EOLC 25718 . 27517) (\FORMATBYTESTREAM 27519
. 29963) (\CHECKEOLC.CRLF 29965 . 33026)) (33029 36945 (MCCSTOFORMATBYTES 33039 . 35438) (
FORMATBYTESTOMCCS 35440 . 36943)) (38356 40650 (\NULLDEVICE 38366 . 40318) (\NULL.OPENFILE 40320 .
40648)) (40731 43542 (ISO1TOMCODE 40741 . 41490) (MTOISO1CODE 41492 . 41782) (\CREATE.ISO1.FORMAT
41784 . 43057) (\DUMMY-UTF8-FORMAT 43059 . 43540)) (43543 45078 (ISO1TOMSTRING 43553 . 44371) (
MTOISO1STRING 44373 . 45076)) (46507 51422 (\CREATE.THROUGH.EXTERNALFORMAT 46517 . 48186) (
\CREATE.THROUGH16.EXTERNALFORMAT 48188 . 50379) (\THROUGHIN 50381 . 50805) (\THROUGHBACKCCODE 50807 .
51078) (\THROUGHOUTCHARFN 51080 . 51420)))))
(FILEMAP (NIL (7168 15089 (\EXTERNALFORMAT 7178 . 11777) (MAKE-EXTERNALFORMAT 11779 . 14616) (
\EXTERNALFORMAT.DEFPRINT 14618 . 15087)) (15090 17955 (\INSTALL.EXTERNALFORMAT 15100 . 16457) (
\REMOVE.EXTERNALFORMAT 16459 . 17206) (FIND-FORMAT 17208 . 17953)) (18373 32648 (\OUTCHAR 18383 .
19600) (\INCCODE 19602 . 20755) (\BACKCCODE 20757 . 22436) (\BACKCCODE.EOLC 22438 . 24628) (\PEEKCCODE
24630 . 24955) (\PEEKCCODE.EOLC 24957 . 25336) (\INCCODE.EOLC 25338 . 27137) (\FORMATBYTESTREAM 27139
. 29583) (\CHECKEOLC.CRLF 29585 . 32646)) (32649 36565 (MCCSTOFORMATBYTES 32659 . 35058) (
FORMATBYTESTOMCCS 35060 . 36563)) (37976 40270 (\NULLDEVICE 37986 . 39938) (\NULL.OPENFILE 39940 .
40268)) (40360 45275 (\CREATE.THROUGH.EXTERNALFORMAT 40370 . 42039) (\CREATE.THROUGH16.EXTERNALFORMAT
42041 . 44232) (\THROUGHIN 44234 . 44658) (\THROUGHBACKCCODE 44660 . 44931) (\THROUGHOUTCHARFN 44933
. 45273)))))
STOP

BIN
sources/EXTERNALFORMAT.LCOM
View File

Binary file not shown.

12
sources/FILESETS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 7-Aug-2025 10:11:01" {WMEDLEY}<sources>FILESETS.;24 6210
(FILECREATED "23-Feb-2026 10:32:36" {WMEDLEY}<sources>FILESETS.;32 6226
:EDIT-BY rmk
:CHANGES-TO (VARS 0LISPSET)
:PREVIOUS-DATE "10-Jun-2025 18:00:09" {WMEDLEY}<sources>FILESETS.;23)
:PREVIOUS-DATE "23-Feb-2026 09:36:51" {WMEDLEY}<sources>FILESETS.;31)
(PRETTYCOMPRINT FILESETSCOMS)
@@ -48,10 +48,10 @@
(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET))
(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO EXTERNALFORMAT IMAGEIO
LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME
CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD IOCHAR MCCS LLCHAR LLSTK
LLDATATYPE LLKEY LLTIMER))
(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO LLARRAYELT
EXTERNALFORMAT IOCHAR UNICODE-FORMATS IMAGEIO LLBASIC LLGC LLINTERP LLMVS
DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD
MCCS LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER))
(RPAQQ 1LISPSET
(ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK ATERM APRINT ABASIC

661
sources/LLARRAYELT
View File

@@ -1,20 +1,19 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "15-Sep-94 11:08:59" {DSK}<lispcore>sources>LLARRAYELT.;7 155360
changes to%: (RECORDS ARRAYP)
(FILECREATED "22-Feb-2026 13:54:48" {WMEDLEY}<sources>LLARRAYELT.;2 169614
previous date%: "28-Jul-94 13:41:50" {DSK}<lispcore>sources>LLARRAYELT.;6)
:EDIT-BY rmk
:CHANGES-TO (VARS LLARRAYELTCOMS)
:PREVIOUS-DATE "15-Sep-94 11:08:59" {WMEDLEY}<sources>LLARRAYELT.;1)
(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT LLARRAYELTCOMS)
(RPAQQ LLARRAYELTCOMS
(RPAQQ LLARRAYELTCOMS
[(COMS (* ;
 "Because we use the UNLESSINEW macro in this file, we need it when compiling.")
 "Because we use the UNLESSINEW macro in this file, we need it when compiling.")
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
RENAMEMACROS)))
(PROPS (LLARRAYELT FILETYPE))
@@ -26,6 +25,10 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH
CL::PUTHASH REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP
\HASHTABLE.DEFPRINT)
(COMS (* ; "Originally on MACHINEINDEPENDENT")
(FNS DMPHASH HASHOVERFLOW)
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST
HASHOVERFLOW.UPDATEARRAY)))
(FNS STRINGHASHBITS STRING-EQUAL-HASHBITS)
(FNS \STRINGHASHBITS-UFN \STRING-EQUAL-HASHBITS-UFN)
(DECLARE%: DONTCOPY (EXPORT (RECORDS HARRAYP)
@@ -44,7 +47,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N)
(CONSTANTS \MAXBUCKETINDEX)
(* ;
 "\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing")
 "\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing")
(EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA
\WORDELT)
(CONSTANTS * BLOCKGCTYPECONSTANTS)
@@ -77,7 +80,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(FNS \ALLOCHUNK)
(VARS \HUNK.PTRSIZES)
(* ;
 "Compiler needs \HUNK.PTRSIZES for creating closure environments")
 "Compiler needs \HUNK.PTRSIZES for creating closure environments")
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER))
(CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES)
(GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE
@@ -152,7 +155,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
RENAMEMACROS)
)
(PUTPROPS LLARRAYELT FILETYPE :BCOMPL)
(PUTPROPS LLARRAYELT FILETYPE :BCOMPL)
@@ -407,8 +410,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
[PUTPROPS ARRAYSIZE DMACRO ((A)
(ffetch (ARRAYP LENGTH) of (\DTEST A 'ARRAYP]
(PUTPROPS ARRAYSIZE DMACRO [(A)
(ffetch (ARRAYP LENGTH) of (\DTEST A 'ARRAYP])
)
)
(DEFINEQ
@@ -996,6 +999,108 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
 "Return T to say we printed it ourselves")
T])
)
(* ; "Originally on MACHINEINDEPENDENT")
(DEFINEQ
(DMPHASH
[NLAMBDA L (* rmk%: " 6-Apr-84 14:30")
(MAPC L (FUNCTION (LAMBDA (ARRAYNAME)
(DECLARE (SPECVARS ARRAYNAME))
(ERSETQ (PROG ((A (EVALV ARRAYNAME 'DMPHASH))
AP)
[PRINT (LIST 'RPAQ ARRAYNAME
(COND
[(LISTP A)
(SETQ AP (CAR A))
(LIST 'CONS [LIST 'HARRAY (HARRAYSIZE AP)
(KWOTE (HARRAYPROP
AP
'OVERFLOW]
(KWOTE (CDR A]
(T (LIST 'HASHARRAY (HARRAYSIZE A)
(KWOTE (HARRAYPROP AP 'OVERFLOW]
(MAPHASH (OR AP A)
(FUNCTION (LAMBDA (VAL ITEM)
(PRINT (LIST 'PUTHASH (KWOTE ITEM)
(KWOTE VAL)
ARRAYNAME])
(HASHOVERFLOW
[LAMBDA (HARRAY) (* ; "Edited 26-Feb-91 13:16 by jds")
(* ;; "Should be called from PUTHASH on hash overflow, but for implementations where PUTHASH calls ERRORX directly, may be called from ERRORX2 when the offender is a listp. HARRAY is guaranteed to be either HARRAYP or (LIST HARRAYP)")
(PROG ((OLDARRAY (HASHOVERFLOW.ARRAYTEST HARRAY))
NEWARRAY NEWSIZE OLDNUMKEYS OVACTION NEWOVFLW)
[COND
((LISTP HARRAY)
(SETQ OVACTION (CDR HARRAY))
(* ;; "Get OVERFLOW method from original HARRAY since it would erroneously be ERROR if we got the method from the coerced OLDARRAY")
(SETQ NEWOVFLW 'ERROR))
(T (SETQ OVACTION (SETQ NEWOVFLW (HARRAYPROP OLDARRAY 'OVERFLOW]
(SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS))
(* ;; "Compute the new array size:")
[SETQ NEWSIZE (SELECTQ OVACTION
(NIL
(* ;; "SIZE*1.5 --- favor to bbn, since pdp-11 doesnt have floatng point, and LRSH on other systems might be faster than IQUOTIENT")
(* ;;
 "[32749 IS THE BIGGEST PRIME < 32765, THE LIMIT ON ARRAY SIZES]")
[IMAX (+ OLDNUMKEYS 3)
(IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS)
1])
(ERROR (do (ERRORX (LIST 26 HARRAY))))
(if (FLOATP OVACTION)
then [IMAX (+ OLDNUMKEYS 3)
(IMIN 32760 (FIXR (FTIMES OLDNUMKEYS OVACTION]
elseif (FIXP OVACTION)
then (IMAX (+ OLDNUMKEYS 3)
(IMIN 32749 (+ OLDNUMKEYS OVACTION)))
elseif [AND (FNTYP OVACTION)
(NUMBERP (SETQ OVACTION (APPLY* OVACTION HARRAY]
then (if (FLOATP OVACTION)
then (* ;
 "recompute NUMKEYS since OVACTION might have removed keys")
[IMAX (+ (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY
'NUMKEYS))
3)
(IMIN 32749 (FIXR (FTIMES OLDNUMKEYS OVACTION]
else OVACTION)
else (* ; "Default: multiply by 1.5")
(SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS))
(IMAX (+ OLDNUMKEYS 3)
(IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS)
1]
[SETQ NEWARRAY (REHASH OLDARRAY (HASHARRAY NEWSIZE NEWOVFLW (HARRAYPROP OLDARRAY
'HASHBITSFN)
(HARRAYPROP OLDARRAY 'EQUIVFN]
(HASHOVERFLOW.UPDATEARRAY HARRAY NEWARRAY OLDARRAY)
(RETURN HARRAY])
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
[PROGN (PUTPROPS HASHOVERFLOW.ARRAYTEST MACRO [(HARRAY)
(CAR (OR (LISTP HARRAY)
(ERRORX (LIST 27 HARRAY])
(PUTPROPS HASHOVERFLOW.ARRAYTEST DMACRO ((HARRAY)
(\DTEST HARRAY 'HARRAYP)))]
[PROGN (PUTPROPS HASHOVERFLOW.UPDATEARRAY MACRO ((HARRAY NEWARRAY OLDARRAY)
(FRPLACA HARRAY NEWARRAY)))
(PUTPROPS HASHOVERFLOW.UPDATEARRAY DMACRO ((HARRAY NEWARRAY OLDARRAY)
(\COPYHARRAYP NEWARRAY OLDARRAY)))]
)
)
(DEFINEQ
(STRINGHASHBITS
@@ -1048,20 +1153,20 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: DONTCOPY
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
(DATATYPE HARRAYP ((NULLSLOTS WORD) (* ;
 "Number of NIL-NIL slots, which break chains")
(LASTINDEX WORD) (* ; "Slot offset of last slot. Used in probe computations computations. Microcode support for \ADDBASE4 would help")
(HARRAYPBASE POINTER)
(RECLAIMABLE FLAG) (* ;
 "True if keys can go away when no other refs")
(OVERFLOWACTION POINTER)
(NUMSLOTS WORD) (* ;
 "The maximum number of logical slots--returned by HARRAYSIZE")
(NUMKEYS WORD) (* ;
 "The number of distinct keys in the array")
(HASHBITSFN POINTER)
(EQUIVFN POINTER)
(HASHUSERDATA POINTER)))
(DATATYPE HARRAYP ((NULLSLOTS WORD) (* ;
 "Number of NIL-NIL slots, which break chains")
(LASTINDEX WORD) (* ; "Slot offset of last slot. Used in probe computations computations. Microcode support for \ADDBASE4 would help")
(HARRAYPBASE POINTER)
(RECLAIMABLE FLAG) (* ;
 "True if keys can go away when no other refs")
(OVERFLOWACTION POINTER)
(NUMSLOTS WORD) (* ;
 "The maximum number of logical slots--returned by HARRAYSIZE")
(NUMKEYS WORD) (* ;
 "The number of distinct keys in the array")
(HASHBITSFN POINTER)
(EQUIVFN POINTER)
(HASHUSERDATA POINTER)))
)
(/DECLAREDATATYPE 'HARRAYP '(WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)
@@ -1078,14 +1183,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
'14)
(DECLARE%: EVAL@COMPILE
[PUTPROPS \EQHASHINGBITS MACRO (OPENLAMBDA (X) (* ;
 "Spread out objects whose low bits are in small arithmetic progression, esp atoms")
(LOGXOR (\HILOC X)
(LOGXOR (LLSH (LOGAND (\LOLOC X)
8191)
3)
(LRSH (\LOLOC X)
9]
(PUTPROPS \EQHASHINGBITS MACRO [OPENLAMBDA (X) (* ;
 "Spread out objects whose low bits are in small arithmetic progression, esp atoms")
(LOGXOR (\HILOC X)
(LOGXOR (LLSH (LOGAND (\LOLOC X)
8191)
3)
(LRSH (\LOLOC X)
9])
)
(* "END EXPORTED DEFINITIONS")
@@ -1094,21 +1199,20 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: EVAL@COMPILE
(BLOCKRECORD HASHSLOT ((KEY POINTER)
(VALUE POINTER))
[ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT])
(VALUE POINTER))
[ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT])
)
(DECLARE%: EVAL@COMPILE
[PUTPROPS \FIRSTINDEX MACRO ((BITS APTR1)
(IREMAINDER BITS (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1]
(PUTPROPS \FIRSTINDEX MACRO [(BITS APTR1)
(IREMAINDER BITS (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1])
(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4))
(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4))
(PUTPROPS \REPROBE MACRO ((BITS HA)
(PUTPROPS \REPROBE MACRO ((BITS HA)
(LOGOR [IREMAINDER (LOGXOR BITS (LRSH BITS 8))
(IMIN 64 (ADD1 (fetch (HARRAYP LASTINDEX)
of HA]
(IMIN 64 (ADD1 (fetch (HARRAYP LASTINDEX) of HA]
1)))
)
@@ -1145,15 +1249,15 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(ADDTOVAR SYSTEMRECLST
(DATATYPE HARRAYP ((NULLSLOTS WORD)
(LASTINDEX WORD)
(HARRAYPBASE POINTER)
(RECLAIMABLE FLAG)
(OVERFLOWACTION POINTER)
(NUMSLOTS WORD)
(NUMKEYS WORD)
(HASHBITSFN POINTER)
(EQUIVFN POINTER)
(HASHUSERDATA POINTER)))
(LASTINDEX WORD)
(HARRAYPBASE POINTER)
(RECLAIMABLE FLAG)
(OVERFLOWACTION POINTER)
(NUMSLOTS WORD)
(NUMKEYS WORD)
(HASHBITSFN POINTER)
(EQUIVFN POINTER)
(HASHUSERDATA POINTER)))
)
(RPAQQ \HASH.NULL.VALUE \Hash\Null\Value\)
@@ -1277,14 +1381,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS EQPTR DMACRO (= . EQ))
(PUTPROPS EQPTR DMACRO (= . EQ))
(PUTPROPS BUCKETINDEX MACRO ((N)
(PUTPROPS BUCKETINDEX MACRO ((N)
(IMIN (INTEGERLENGTH N)
\MAXBUCKETINDEX)))
[PUTPROPS FREEBLOCKCHAIN.N MACRO ((N)
(\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N]
(PUTPROPS FREEBLOCKCHAIN.N MACRO ((N)
(\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N))))
)
(DECLARE%: EVAL@COMPILE
@@ -1297,43 +1401,43 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N)
(\ADDBASE (\ADDBASE BASE N)
N)))
(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N)
(\ADDBASE (\ADDBASE BASE N)
N)))
(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N)
(\ADDBASE2 (\ADDBASE2 BASE N)
N)))
(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N)
(\ADDBASE2 (\ADDBASE2 BASE N)
N)))
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
(FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
WORDSPERCELL)))
[PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J)
(\GETBASEBYTE (fetch (ARRAYP BASE) of A)
(IPLUS (fetch (ARRAYP OFFST) of A)
J]
(PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J)
(\GETBASEBYTE (fetch (ARRAYP BASE) of A)
(IPLUS (fetch (ARRAYP OFFST) of A)
J))))
(PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V)
(\PUTBASEBYTE (fetch (ARRAYP BASE) of A)
(IPLUS (fetch (ARRAYP OFFST) of A)
J)
V)))
(PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V)
(\PUTBASEBYTE (fetch (ARRAYP BASE) of A)
(IPLUS (fetch (ARRAYP OFFST) of A)
J)
V)))
[PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J)
[CHECK (AND (ARRAYP A)
(EQ 0 (fetch (ARRAYP ORIG) of A))
(EQ \ST.POS16 (fetch (ARRAYP TYP) of A]
(CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A)
J))
(\GETBASE (fetch (ARRAYP BASE) of A)
(IPLUS (fetch (ARRAYP OFFST) of A)
J]
(PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J)
[CHECK (AND (ARRAYP A)
(EQ 0 (fetch (ARRAYP ORIG) of A))
(EQ \ST.POS16 (fetch (ARRAYP TYP) of A]
(CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A)
J))
(\GETBASE (fetch (ARRAYP BASE) of A)
(IPLUS (fetch (ARRAYP OFFST) of A)
J))))
)
(RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2)
(PTRBLOCK.GCT 1)
(UNBOXEDBLOCK.GCT 0)))
(PTRBLOCK.GCT 1)
(UNBOXEDBLOCK.GCT 0)))
(DECLARE%: EVAL@COMPILE
(RPAQQ CODEBLOCK.GCT 2)
@@ -1348,33 +1452,24 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(UNBOXEDBLOCK.GCT 0))
)
(RPAQQ ARRAYCONSTANTS (\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells
\ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS
\ArrayBlockHeaderCells
\ArrayBlockTrailerCells
))
(\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords
\ArrayBlockTrailerWords))
\ArrayBlockLinkingCells
(\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells
\ArrayBlockLinkingCells))
(\MaxArrayBlockSize 65535)
(\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize
\ArrayBlockOverheadCells))
\MaxArrayLen
(\ABPASSWORDSHIFT 3)
(\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
(\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword
\ABPASSWORDSHIFT)
(LLSH UNBOXEDBLOCK.GCT 1)))
(\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword
\ABPASSWORDSHIFT)
1))
(\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword
\ABPASSWORDSHIFT)
(LLSH CODEBLOCK.GCT 1)
1))))
(RPAQQ ARRAYCONSTANTS
(\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells \ArrayBlockTrailerWords
(\ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells \ArrayBlockTrailerCells))
(\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords))
\ArrayBlockLinkingCells
(\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells))
(\MaxArrayBlockSize 65535)
(\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells))
\MaxArrayLen
(\ABPASSWORDSHIFT 3)
(\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
(\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH UNBOXEDBLOCK.GCT 1)))
(\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
1))
(\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH CODEBLOCK.GCT 1)
1))))
(DECLARE%: EVAL@COMPILE
(RPAQQ \ArrayBlockHeaderCells 1)
@@ -1404,14 +1499,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(RPAQ \ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
(RPAQ \FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH UNBOXEDBLOCK.GCT 1)))
(LLSH UNBOXEDBLOCK.GCT 1)))
(RPAQ \UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
1))
1))
(RPAQ \CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH CODEBLOCK.GCT 1)
1))
(LLSH CODEBLOCK.GCT 1)
1))
(CONSTANTS \ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells
@@ -1435,13 +1530,13 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
)
(RPAQQ ARRAYTYPES ((\ST.BYTE 0)
(\ST.POS16 1)
(\ST.INT32 2)
(\ST.CODE 4)
(\ST.PTR 6)
(\ST.FLOAT 7)
(\ST.BIT 8)
(\ST.PTR2 11)))
(\ST.POS16 1)
(\ST.INT32 2)
(\ST.CODE 4)
(\ST.PTR 6)
(\ST.FLOAT 7)
(\ST.BIT 8)
(\ST.PTR2 11)))
(DECLARE%: EVAL@COMPILE
(RPAQQ \ST.BYTE 0)
@@ -1487,52 +1582,51 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: EVAL@COMPILE
(BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1)
(NIL BITS 1)
(READONLY FLAG)
(NIL BITS 1)
(BASE POINTER)
(TYP BITS 4)
(NIL BITS 4)
(LENGTH BITS 24)
(OFFST FIXP)))
(NIL BITS 1)
(READONLY FLAG)
(NIL BITS 1)
(BASE POINTER)
(TYP BITS 4)
(NIL BITS 4)
(LENGTH BITS 24)
(OFFST FIXP)))
(DATATYPE ARRAYP (
(* ;; "Describes an INTERLISP ARRAYP, as opposed to a CL array.")
(* ;; "Describes an INTERLISP ARRAYP, as opposed to a CL array.")
(ORIG BITS 1) (* ; "Origin, 0 or 1")
(NIL BITS 1)
(READONLY FLAG) (* ; "probably no READONLY arrays now")
(NIL BITS 1)
(BASE POINTER)
(TYP BITS 4) (* ; "Type of the contents")
(NIL BITS 4)
(LENGTH BITS 24) (* ; "Array's length")
(OFFST FIXP) (* ;
 "Offset from BASE where the data really starts.")
)
(ORIG BITS 1) (* ; "Origin, 0 or 1")
(NIL BITS 1)
(READONLY FLAG) (* ; "probably no READONLY arrays now")
(NIL BITS 1)
(BASE POINTER)
(TYP BITS 4) (* ; "Type of the contents")
(NIL BITS 4)
(LENGTH BITS 24) (* ; "Array's length")
(OFFST FIXP) (* ;
 "Offset from BASE where the data really starts.")
)
(* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}")
(* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}")
)
)
(BLOCKRECORD ARRAYBLOCK ((PASSWORD BITS 13)
(GCTYPE BITS 2) (* ; "Unboxed, Pointers, or Code")
(INUSE FLAG)
(ARLEN WORD)
(FWD FULLXPOINTER) (* ; "Only when on free list")
(BKWD FULLXPOINTER))
(BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD)
(GCTYPE BITS 2) (* ; "Unboxed, Pointers, or Code")
(INUSE FLAG)
(ARLEN WORD)
(FWD FULLXPOINTER) (* ; "Only when on free list")
(BKWD FULLXPOINTER))
(BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD)
(* ; "Used for header and trailer")
))
[ACCESSFNS ARRAYBLOCK ((DAT (\ADDBASE DATUM \ArrayBlockHeaderWords))
(TRAILER (\ADDBASE2 DATUM
(IDIFFERENCE (fetch
(ARRAYBLOCK ARLEN)
of DATUM)
))
[ACCESSFNS ARRAYBLOCK ((DAT (\ADDBASE DATUM \ArrayBlockHeaderWords))
(TRAILER (\ADDBASE2 DATUM (IDIFFERENCE
(fetch (ARRAYBLOCK ARLEN)
of DATUM)
\ArrayBlockTrailerCells]
(TYPE? (AND (EQ 0 (NTYPX DATUM))
(IGEQ (\HILOC DATUM)
\FirstArraySegment))))
(TYPE? (AND (EQ 0 (NTYPX DATUM))
(IGEQ (\HILOC DATUM)
\FirstArraySegment))))
)
(/DECLAREDATATYPE 'ARRAYP '((BITS 1)
@@ -2273,8 +2367,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: EVAL@COMPILE
(BLOCKRECORD SAFTABLE ((SAFITEMS WORD)
(NIL WORD)
(SAFCELLS FIXP)))
(NIL WORD)
(SAFCELLS FIXP)))
)
)
@@ -2484,7 +2578,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: EVAL@COMPILE DONTCOPY
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
(FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
WORDSPERCELL)))
)
@@ -2494,8 +2588,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: EVAL@COMPILE
(RPAQQ \HUNK.UNBOXEDSIZES
(1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64))
(RPAQQ \HUNK.UNBOXEDSIZES (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64))
(RPAQQ \HUNK.CODESIZES (12 16 20 24 28 32 36 42 50 64))
@@ -2721,49 +2814,49 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
(DECLARE%: DONTCOPY
(ADDTOVAR INITVALUES (\NxtArrayPage)
(\HUNKING?))
(\HUNKING?))
(ADDTOVAR INITPTRS (\FREEBLOCKBUCKETS)
(\ArrayFrLst)
(\ArrayFrLst2)
(\UNBOXEDHUNK.TYPENUM.TABLE)
(\CODEHUNK.TYPENUM.TABLE)
(\PTRHUNK.TYPENUM.TABLE))
(\ArrayFrLst)
(\ArrayFrLst2)
(\UNBOXEDHUNK.TYPENUM.TABLE)
(\CODEHUNK.TYPENUM.TABLE)
(\PTRHUNK.TYPENUM.TABLE))
(ADDTOVAR INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? \ALLOCBLOCK \MAIKO.ALLOCBLOCK
\ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK \ALLOCHUNK)
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
FILEPATCHBLOCK)
(FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING
\SETUP.TYPENUM.TABLE))
\ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK \ALLOCHUNK)
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
FILEPATCHBLOCK)
(FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING
\SETUP.TYPENUM.TABLE))
(ADDTOVAR MKI.SUBFNS (\IN.MAKEINIT . T)
(\ALLOCBLOCK.OLD . NILL)
(\MERGEFORWARD . NILL)
(\FIXCODENUM . I.FIXUPNUM)
(\FIXCODESYM . I.FIXUPSYM)
(\FIXCODEPTR . I.FIXUPPTR)
(\CHECKARRAYBLOCK . NILL)
(\ARRAYMERGING PROGN NIL))
(\ALLOCBLOCK.OLD . NILL)
(\MERGEFORWARD . NILL)
(\FIXCODENUM . I.FIXUPNUM)
(\FIXCODESYM . I.FIXUPSYM)
(\FIXCODEPTR . I.FIXUPPTR)
(\CHECKARRAYBLOCK . NILL)
(\ARRAYMERGING PROGN NIL))
(ADDTOVAR EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER BUCKETINDEX FREEBLOCKCHAIN.N)
(ADDTOVAR RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1))
(ADDTOVAR RD.SUBFNS (EQPTR . EQUAL)
(ARRAYBLOCKCHECKING . T))
(ARRAYBLOCKCHECKING . T))
(ADDTOVAR RDPTRS (\FREEBLOCKBUCKETS))
(ADDTOVAR RDVALS (\ArrayFrLst)
(\ArrayFrLst2))
(\ArrayFrLst2))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER
FILECODEBLOCK FILEPATCHBLOCK)
(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
FILEPATCHBLOCK)
(ADDTOVAR DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING
\SETUP.TYPENUM.TABLE)
\SETUP.TYPENUM.TABLE)
)
@@ -2937,32 +3030,174 @@ EVAL@COMPILE
(ADDTOVAR LAMA CL::PUTHASH HARRAYPROP)
)
(PUTPROPS LLARRAYELT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989
1990 1991 1992 1993 1994))
(PRETTYCOMPRINT LLARRAYELTCOMS)
(RPAQQ LLARRAYELTCOMS
[(COMS (* ;
 "Because we use the UNLESSINEW macro in this file, we need it when compiling.")
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
RENAMEMACROS)))
(PROPS (LLARRAYELT FILETYPE))
(COMS (* ; "ARRAY entries")
(FNS AIN AOUT ARRAY ARRAYSIZE ARRAYTYP ARRAYORIG COPYARRAY)
(DECLARE%: DONTCOPY (MACROS ARRAYSIZE))
(FNS ELT ELTD SETA SETD SUBARRAY))
[COMS (* ; "HASHARRAY entries")
(FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH
CL::PUTHASH REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP
\HASHTABLE.DEFPRINT)
(COMS (* ; "Originally on MACHINEINDEPENDENT")
(FNS DMPHASH HASHOVERFLOW)
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST
HASHOVERFLOW.UPDATEARRAY)))
(FNS STRINGHASHBITS STRING-EQUAL-HASHBITS)
(FNS \STRINGHASHBITS-UFN \STRING-EQUAL-HASHBITS-UFN)
(DECLARE%: DONTCOPY (EXPORT (RECORDS HARRAYP)
(MACROS \EQHASHINGBITS))
(RECORDS HASHSLOT)
(MACROS \FIRSTINDEX \HASHSLOT \REPROBE)
(CONSTANTS (CELLSPERSLOT 2))
(GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY))
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'HARRAYP '\HASHTABLE.DEFPRINT]
(INITRECORDS HARRAYP)
(SYSRECORDS HARRAYP)
(VARS (\HASH.NULL.VALUE '\Hash\Null\Value\]
(COMS (* ; "System entries for CODE")
(FNS \CODEARRAY \FIXCODENUM \FIXCODEPTR \FIXCODESYM))
(COMS (* ; "Internal")
(DECLARE%: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N)
(CONSTANTS \MAXBUCKETINDEX)
(* ;
 "\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing")
(EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA
\WORDELT)
(CONSTANTS * BLOCKGCTYPECONSTANTS)
(CONSTANTS * ARRAYCONSTANTS)
(CONSTANTS * ARRAYTYPES)
(CONSTANTS \MAX.CELLSPERHUNK)
(CONSTANTS (\IN.MAKEINIT))
(RECORDS SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK)
(GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?))
(GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN))
(FNS \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.OLD \ALLOCBLOCK.NEW \PREFIXALIGNMENT?
\MAKEFREEARRAYBLOCK \DELETEBLOCK? \LINKBLOCK \MERGEBACKWARD \MERGEFORWARD
\ARRAYBLOCKMERGER \#BLOCKDATACELLS \COPYARRAYBLOCK \RECLAIMARRAYBLOCK
\ADVANCE.ARRAY.SEGMENTS)
(ADDVARS (\MAIKO.MOVDS (\MAIKO.ALLOCBLOCK \ALLOCBLOCK)))
(FNS \BYTELT \BYTESETA \WORDELT)
(FNS \ARRAYTYPENAME)
(VARS (\ARRAYMERGING T))
(GLOBALVARS \ARRAYMERGING)
(COMS (* ; "for STORAGE")
(FNS \SHOW.ARRAY.FREELISTS)
(INITVARS (\ABSTORAGETABLE NIL))
(GLOBALVARS \ABSTORAGETABLE)
(DECLARE%: DONTCOPY (RECORDS SAFTABLE)))
(COMS (* ; "Debugging and RDSYS")
(FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1)
(INITVARS (ARRAYBLOCKCHECKING))
(GLOBALVARS ARRAYBLOCKCHECKING)))
(COMS (* ; "Basic hunking")
(FNS \ALLOCHUNK)
(VARS \HUNK.PTRSIZES)
(* ;
 "Compiler needs \HUNK.PTRSIZES for creating closure environments")
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER))
(CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES)
(GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE
\PTRHUNK.TYPENUM.TABLE))
(COMS
(* ;; "Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage")
(VARS (\HUNKREJECTS))
(GLOBALVARS \HUNKREJECTS)))
[COMS (* ; "for MAKEINIT")
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
FILEPATCHBLOCK)
(COMS (* ; "Hunk Initialization")
(FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING
\SETUP.TYPENUM.TABLE))
(DECLARE%: DONTCOPY (ADDVARS (INITVALUES (\NxtArrayPage)
(\HUNKING?))
(INITPTRS (\FREEBLOCKBUCKETS)
(\ArrayFrLst)
(\ArrayFrLst2)
(\UNBOXEDHUNK.TYPENUM.TABLE)
(\CODEHUNK.TYPENUM.TABLE)
(\PTRHUNK.TYPENUM.TABLE))
(INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT?
\ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.NEW
\MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK
\ALLOCHUNK)
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE
FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK)
(FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS
\TURN.ON.HUNKING \SETUP.TYPENUM.TABLE))
(MKI.SUBFNS (\IN.MAKEINIT . T)
(\ALLOCBLOCK.OLD . NILL)
(\MERGEFORWARD . NILL)
(\FIXCODENUM . I.FIXUPNUM)
(\FIXCODESYM . I.FIXUPSYM)
(\FIXCODEPTR . I.FIXUPPTR)
(\CHECKARRAYBLOCK . NILL)
(\ARRAYMERGING PROGN NIL))
(EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER
BUCKETINDEX FREEBLOCKCHAIN.N)
(RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE
\PARSEARRAYSPACE1))
(RD.SUBFNS (EQPTR . EQUAL)
(ARRAYBLOCKCHECKING . T))
(RDPTRS (\FREEBLOCKBUCKETS))
(RDVALS (\ArrayFrLst)
(\ArrayFrLst2)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE
FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK)
(DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS
\TURN.ON.HUNKING \SETUP.TYPENUM.TABLE]
(COMS (* ; "Debugging aids")
(DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \ArrayFrLst)
(CONSTANTS \ArrayBlockPassword)
(ADDVARS (DONTCOMPILEFNS \HUNKFIT? \AB.NEXT \AB.BACK)))
(FNS \HUNKFIT? \AB.NEXT \AB.BACK))
(LOCALVARS . T)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DMPHASH)
(NLAML)
(LAMA CL::PUTHASH
HARRAYPROP])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DMPHASH)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CL::PUTHASH HARRAYPROP)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (9739 22117 (AIN 9749 . 12022) (AOUT 12024 . 14626) (ARRAY 14628 . 20213) (ARRAYSIZE
20215 . 20355) (ARRAYTYP 20357 . 20953) (ARRAYORIG 20955 . 21122) (COPYARRAY 21124 . 22115)) (22283
29928 (ELT 22293 . 23722) (ELTD 23724 . 24649) (SETA 24651 . 26908) (SETD 26910 . 27904) (SUBARRAY
27906 . 29926)) (29963 55572 (HARRAY 29973 . 30193) (HASHARRAY 30195 . 34218) (HARRAYP 34220 . 34369)
(HARRAYPROP 34371 . 38406) (HARRAYSIZE 38408 . 38573) (CLRHASH 38575 . 39947) (MAPHASH 39949 . 41078)
(GETHASH 41080 . 44660) (PUTHASH 44662 . 44893) (CL::PUTHASH 44895 . 45607) (REMHASH 45609 . 45754) (
\HASHRECLAIM 45756 . 47539) (\HASHACCESS 47541 . 53303) (REHASH 53305 . 54029) (\COPYHARRAYP 54031 .
54761) (\HASHTABLE.DEFPRINT 54763 . 55570)) (55573 56129 (STRINGHASHBITS 55583 . 55740) (
STRING-EQUAL-HASHBITS 55742 . 56127)) (56130 58192 (\STRINGHASHBITS-UFN 56140 . 57246) (
\STRING-EQUAL-HASHBITS-UFN 57248 . 58190)) (62479 67574 (\CODEARRAY 62489 . 63319) (\FIXCODENUM 63321
. 63986) (\FIXCODEPTR 63988 . 65048) (\FIXCODESYM 65050 . 67572)) (79255 114491 (\ALLOCBLOCK 79265 .
83264) (\MAIKO.ALLOCBLOCK 83266 . 87458) (\ALLOCBLOCK.OLD 87460 . 92331) (\ALLOCBLOCK.NEW 92333 .
95339) (\PREFIXALIGNMENT? 95341 . 98884) (\MAKEFREEARRAYBLOCK 98886 . 99481) (\DELETEBLOCK? 99483 .
100588) (\LINKBLOCK 100590 . 102716) (\MERGEBACKWARD 102718 . 104079) (\MERGEFORWARD 104081 . 105178)
(\ARRAYBLOCKMERGER 105180 . 107365) (\#BLOCKDATACELLS 107367 . 108603) (\COPYARRAYBLOCK 108605 .
110173) (\RECLAIMARRAYBLOCK 110175 . 112304) (\ADVANCE.ARRAY.SEGMENTS 112306 . 114489)) (114553 116986
(\BYTELT 114563 . 115362) (\BYTESETA 115364 . 116305) (\WORDELT 116307 . 116984)) (116987 117321 (
\ARRAYTYPENAME 116997 . 117319)) (117444 121138 (\SHOW.ARRAY.FREELISTS 117454 . 121136)) (121451
127201 (\CHECKARRAYBLOCK 121461 . 125836) (\PARSEARRAYSPACE 125838 . 126247) (\PARSEARRAYSPACE1 126249
. 127199)) (127335 133601 (\ALLOCHUNK 127345 . 133599)) (134779 140675 (PREINITARRAYS 134789 . 135330
) (POSTINITARRAYS 135332 . 138050) (FILEARRAYBASE 138052 . 138464) (FILEBLOCKTRAILER 138466 . 138761)
(FILECODEBLOCK 138763 . 139779) (FILEPATCHBLOCK 139781 . 140673)) (140712 146136 (
\SETUP.HUNK.TYPENUMBERS 140722 . 141758) (\COMPUTE.HUNK.TYPEDECLS 141760 . 143040) (\TURN.ON.HUNKING
143042 . 143714) (\SETUP.TYPENUM.TABLE 143716 . 146134)) (148399 155000 (\HUNKFIT? 148409 . 149024) (
\AB.NEXT 149026 . 152221) (\AB.BACK 152223 . 154998)))))
(FILEMAP (NIL (9935 22313 (AIN 9945 . 12218) (AOUT 12220 . 14822) (ARRAY 14824 . 20409) (ARRAYSIZE
20411 . 20551) (ARRAYTYP 20553 . 21149) (ARRAYORIG 21151 . 21318) (COPYARRAY 21320 . 22311)) (22488
30133 (ELT 22498 . 23927) (ELTD 23929 . 24854) (SETA 24856 . 27113) (SETD 27115 . 28109) (SUBARRAY
28111 . 30131)) (30168 55777 (HARRAY 30178 . 30398) (HASHARRAY 30400 . 34423) (HARRAYP 34425 . 34574)
(HARRAYPROP 34576 . 38611) (HARRAYSIZE 38613 . 38778) (CLRHASH 38780 . 40152) (MAPHASH 40154 . 41283)
(GETHASH 41285 . 44865) (PUTHASH 44867 . 45098) (CL::PUTHASH 45100 . 45812) (REMHASH 45814 . 45959) (
\HASHRECLAIM 45961 . 47744) (\HASHACCESS 47746 . 53508) (REHASH 53510 . 54234) (\COPYHARRAYP 54236 .
54966) (\HASHTABLE.DEFPRINT 54968 . 55775)) (55827 61097 (DMPHASH 55837 . 57451) (HASHOVERFLOW 57453
. 61095)) (61873 62429 (STRINGHASHBITS 61883 . 62040) (STRING-EQUAL-HASHBITS 62042 . 62427)) (62430
64492 (\STRINGHASHBITS-UFN 62440 . 63546) (\STRING-EQUAL-HASHBITS-UFN 63548 . 64490)) (68675 73770 (
\CODEARRAY 68685 . 69515) (\FIXCODENUM 69517 . 70182) (\FIXCODEPTR 70184 . 71244) (\FIXCODESYM 71246
. 73768)) (84170 119406 (\ALLOCBLOCK 84180 . 88179) (\MAIKO.ALLOCBLOCK 88181 . 92373) (
\ALLOCBLOCK.OLD 92375 . 97246) (\ALLOCBLOCK.NEW 97248 . 100254) (\PREFIXALIGNMENT? 100256 . 103799) (
\MAKEFREEARRAYBLOCK 103801 . 104396) (\DELETEBLOCK? 104398 . 105503) (\LINKBLOCK 105505 . 107631) (
\MERGEBACKWARD 107633 . 108994) (\MERGEFORWARD 108996 . 110093) (\ARRAYBLOCKMERGER 110095 . 112280) (
\#BLOCKDATACELLS 112282 . 113518) (\COPYARRAYBLOCK 113520 . 115088) (\RECLAIMARRAYBLOCK 115090 .
117219) (\ADVANCE.ARRAY.SEGMENTS 117221 . 119404)) (119468 121901 (\BYTELT 119478 . 120277) (\BYTESETA
120279 . 121220) (\WORDELT 121222 . 121899)) (121902 122236 (\ARRAYTYPENAME 121912 . 122234)) (122359
126053 (\SHOW.ARRAY.FREELISTS 122369 . 126051)) (126358 132108 (\CHECKARRAYBLOCK 126368 . 130743) (
\PARSEARRAYSPACE 130745 . 131154) (\PARSEARRAYSPACE1 131156 . 132106)) (132242 138508 (\ALLOCHUNK
132252 . 138506)) (139686 145582 (PREINITARRAYS 139696 . 140237) (POSTINITARRAYS 140239 . 142957) (
FILEARRAYBASE 142959 . 143371) (FILEBLOCKTRAILER 143373 . 143668) (FILECODEBLOCK 143670 . 144686) (
FILEPATCHBLOCK 144688 . 145580)) (145619 151043 (\SETUP.HUNK.TYPENUMBERS 145629 . 146665) (
\COMPUTE.HUNK.TYPEDECLS 146667 . 147947) (\TURN.ON.HUNKING 147949 . 148621) (\SETUP.TYPENUM.TABLE
148623 . 151041)) (153219 159820 (\HUNKFIT? 153229 . 153844) (\AB.NEXT 153846 . 157041) (\AB.BACK
157043 . 159818)))))
STOP

BIN
sources/LLARRAYELT.LCOM
View File

Binary file not shown.

2739
sources/UNICODE-FORMATS Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
sources/UNICODE-FORMATS.LCOM Normal file
View File

Binary file not shown.