diff --git a/lispusers/CHARCODEUTILS b/lispusers/CHARCODEUTILS new file mode 100644 index 000000000..40a69bc47 --- /dev/null +++ b/lispusers/CHARCODEUTILS @@ -0,0 +1,178 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "27-Mar-2025 23:27:17" {DSK}matt>Interlisp>medley>lispusers>CHARCODEUTILS.;19 10047 + + :EDIT-BY "mth" + + :CHANGES-TO (FUNCTIONS \MAKE-CHARCODE.ENCODE-TABLE CHARCODE.ENCODE \TEST.CHARCODE.ENCODE) + (VARS CHARCODEUTILSCOMS) + + :PREVIOUS-DATE "27-Mar-2025 22:49:46" +{DSK}matt>Interlisp>medley>lispusers>CHARCODEUTILS.;15) + + +(PRETTYCOMPRINT CHARCODEUTILSCOMS) + +(RPAQQ CHARCODEUTILSCOMS ((FUNCTIONS CHARCODE.ENCODE \MAKE-CHARCODE.ENCODE-TABLE + \TEST.CHARCODE.ENCODE) + (PROP (FILETYPE MAKEFILE-ENVIRONMENT) + CHARCODEUTILS))) + +(CL:DEFUN CHARCODE.ENCODE (CCODE &OPTIONAL (CHNAMES.TABLE NIL) + (NONCHAR.IDENTITY NIL)) (* ; "Edited 27-Mar-2025 23:25 by mth") + (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES)) + (CL:WHEN CCODE (* ; "Is there anything to do?") + (SETQ CHNAMES.TABLE (OR CHNAMES.TABLE (\MAKE-CHARCODE.ENCODE-TABLE CHARACTERNAMES))) + [COND + ((LISTP CCODE) + (CONS (CHARCODE.ENCODE (CAR CCODE) + CHNAMES.TABLE NONCHAR.IDENTITY) + (CHARCODE.ENCODE (CDR CCODE) + CHNAMES.TABLE NONCHAR.IDENTITY))) + ([NOT (OR (AND (SMALLP CCODE) + (IGEQ CCODE 0)) + (AND (CL:CHARACTERP CCODE) + (SETQ CCODE (CL:CHAR-CODE CCODE] + (AND NONCHAR.IDENTITY CCODE)) + (T (LET [[HASHBIT (CONSTANT (PROGN + (* ;; "The bit set by the # in CHARCODE.DECODE") + + (CL:PARSE-INTEGER "10000000" :RADIX 2] + [CTRLMASK (CONSTANT (PROGN + (* ;; "Mask of bits present if NOT control or #") + + (* ;; + "= Mask of bits cleared by the ^ in CHARCODE.DECODE") + + (CL:PARSE-INTEGER "01100000" :RADIX 2] + (UNCTRLBIT (CONSTANT (PROGN + (* ;; + "Bit to turn on to make char for reporting a control character") + + (CL:PARSE-INTEGER "01000000" :RADIX 2] + (CL:LABELS ((CHCODE (CX) + (LOGAND CX 255)) + (CHARSET (CX) + (LRSH CX 8)) + (CTRLP (CX) + (NOT (BITTEST CX CTRLMASK))) + (HASHP (CX) + (BITTEST CX HASHBIT))) + (PROG* ((CSET (CHARSET CCODE)) + (CC (CHCODE CCODE)) + (CTRL (AND (CTRLP CC) + "^")) + (HASH (AND (HASHP CC) + "#")) + (CSLIST (CDR (ASSOC CSET CHNAMES.TABLE))) + (CS0LIST (CDR (ASSOC 0 CHNAMES.TABLE))) + CNAME TEMP TC) + (CL:UNLESS CS0LIST (CL:ERROR + "No character set 0 entries in the CHNAMES.TABLE" + )) + (CL:WHEN CSLIST + + (* ;; "Exact charset list exists, check there first") + + (SETQ TEMP (COND + ((CL:FIND CCODE CSLIST :KEY #'CL:SECOND)) + [(AND CTRL HASH (CL:FIND CCODE CSLIST :KEY + #'CL:THIRD] + [(AND CTRL (CL:FIND CCODE CSLIST :KEY #'CL:FOURTH] + [(AND HASH (CL:FIND CCODE CSLIST :KEY #'CL:FIFTH] + (T NIL))) + (CL:WHEN TEMP + (CL:WHEN [CTRLP (SETQ TC (CHCODE (CL:SECOND TEMP] + (SETQ CTRL NIL)) + (CL:WHEN (HASHP TC) + (SETQ HASH NIL)) + (SETQ CNAME (CAR TEMP)) + (SETQ CSET 0))) + (CL:UNLESS (OR TEMP (EQ CSLIST CS0LIST)) + + (* ;; "We may have already done this, don't repeat") + + (SETQ TEMP (COND + ((CL:FIND CC CS0LIST :KEY #'CL:SECOND)) + [(AND CTRL HASH (CL:FIND CC CS0LIST :KEY + #'CL:THIRD] + [(AND CTRL (CL:FIND CC CS0LIST :KEY #'CL:FOURTH] + [(AND HASH (CL:FIND CC CS0LIST :KEY #'CL:FIFTH] + (T NIL))) + (CL:WHEN TEMP + (CL:WHEN (CTRLP (SETQ TC (CL:SECOND TEMP))) + (SETQ CTRL NIL)) + (CL:WHEN (HASHP TC) + (SETQ HASH NIL)) + (SETQ CNAME (CAR TEMP)))) + [SETQ CSET (COND + ((ZEROP CSET) + + (* ;; "Can skip cset=0 prefix") + + NIL) + [(CAR (CL:RASSOC CSET CHARACTERSETNAMES :KEY + #'CAR] + (CSET (OCTALSTRING CSET] + (RETURN (CONCAT (OR CSET "") + (OR (AND CSET ",") + "") + (OR HASH "") + (OR CTRL "") + (OR CNAME (CHARACTER (LOGOR (BITCLEAR CC HASHBIT) + (OR (AND CTRL UNCTRLBIT) + 0])) + +(CL:DEFUN \MAKE-CHARCODE.ENCODE-TABLE (CNAMES) + (DECLARE (GLOBALVARS CHARACTERNAMES)) (* ; "Edited 27-Mar-2025 23:25 by mth") + [LET [[HASHBIT (CONSTANT (PROGN + (* ;; "The bit set by the # in CHARCODE.DECODE") + + (CL:PARSE-INTEGER "10000000" :RADIX 2] + (CTRLMASK (CONSTANT (PROGN + (* ;; "Mask of bits cleared by the ^ in CHARCODE.DECODE") + + (CL:PARSE-INTEGER "01100000" :RADIX 2] + (CL:LABELS ((CHCODE (CX) + (LOGAND CX 255)) + (CHARSET (CX) + (LRSH CX 8))) + (CL:LOOP :FOR CNI :IN (OR CNAMES CHARACTERNAMES) + :WITH TABLE := (LIST (LIST 0)) + :AND CNAME :AND CSET :AND CCODE :AND CTRLCC :AND TROW :AND CSLIST :DO + (SETQ CNAME (MKSTRING (CAR CNI))) + (SETQ CCODE (CADR CNI)) + (SETQ CCODE (OR (SMALLP CCODE) + (CHARCODE.DECODE CCODE NIL))) + (SETQ CSET (CHARSET CCODE)) + (SETQ TROW (LIST CNAME CCODE (LOGOR (SETQ CTRLCC (BITCLEAR CCODE CTRLMASK)) + HASHBIT) + CTRLCC + (LOGOR CCODE HASHBIT))) + (SETQ CSLIST (ASSOC CSET TABLE)) + (CL:UNLESS CSLIST + (NCONC1 TABLE (SETQ CSLIST (LIST CSET)))) + (NCONC1 CSLIST TROW) + :FINALLY + (CL:IF (ASSOC 0 TABLE) + (RETURN TABLE) + (CL:ERROR "No character set 0 entries in CHARACTERNAMES"))]) + +(CL:DEFUN \TEST.CHARCODE.ENCODE (&OPTIONAL (CHTABLE (\MAKE-CHARCODE.ENCODE-TABLE NIL))) + (* ; "Edited 27-Mar-2025 23:27 by mth") + [CL:LOOP :FOR CH :FROM 0 :TO 65535 :WITH CAN.CHARNAME = (CL:FBOUNDP 'CHARNAME) + :AND ENC :AND DEC :NCONC (AND (NEQ CH (SETQ DEC (CHARCODE.DECODE (SETQ ENC (CHARCODE.ENCODE + CH CHTABLE)) + T))) + (LIST (LIST* :INPUT CH :ENCODED ENC :DECODED DEC + (AND CAN.CHARNAME (LIST :CHARNAME (CHARNAME + CH]) + +(PUTPROPS CHARCODEUTILS FILETYPE :COMPILE-FILE) + +(PUTPROPS CHARCODEUTILS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) +(PUTPROPS CHARCODEUTILS COPYRIGHT (NONE)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (748 7089 (CHARCODE.ENCODE 748 . 7089)) (7091 8982 (\MAKE-CHARCODE.ENCODE-TABLE 7091 . +8982)) (8984 9824 (\TEST.CHARCODE.ENCODE 8984 . 9824))))) +STOP diff --git a/lispusers/CHARCODEUTILS.DFASL b/lispusers/CHARCODEUTILS.DFASL new file mode 100644 index 000000000..a3a5b71e2 Binary files /dev/null and b/lispusers/CHARCODEUTILS.DFASL differ