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

Rmk161 loadup works with utf 8 source files (#2512)

Browse Source 
* New starter.sysout contains the UTF-8 external format
* Init.sysout is created with the UTF-8 external format
* Files with non-ascii characters and some other files converted to UTF-8, for basic testing
* Environment arg of WITH-READER-ENVIRONMENT can be a stream
* Compiler functions now respect the external format as copied from the source file
* Colon is the package delimiter in DEFINE-FILE-INFO expressions
* UNICODE file is deprecated in favor of UNICODE-FORMATS and UNICODE-TABLES
This commit is contained in:
rmkaplan
2026-03-02 11:56:11 -08:00
committed by GitHub
parent b1bdd90338
commit 0f470b9753
54 changed files with 9450 additions and 7320 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
internal/loadups/LOADUP-FULL
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 5-Feb-2026 10:26:39" {WMEDLEY}<internal>loadups>LOADUP-FULL.;36 5858
(FILECREATED "14-Feb-2026 00:42:39" {WMEDLEY}<internal>loadups>LOADUP-FULL.;38 5967
:EDIT-BY rmk
:CHANGES-TO (FNS LOADUP-FULL)
:PREVIOUS-DATE "28-Dec-2025 12:06:12" {WMEDLEY}<internal>loadups>LOADUP-FULL.;35)
:PREVIOUS-DATE "13-Feb-2026 00:47:52" {WMEDLEY}<internal>loadups>LOADUP-FULL.;37)
(PRETTYCOMPRINT LOADUP-FULLCOMS)
@@ -47,7 +47,8 @@
(PRINTOUT T "FULL fonts loaded" T])
(LOADUP-FULL
[LAMBDA (DRIBBLEFILE) (* ; "Edited 5-Feb-2026 10:26 by rmk")
[LAMBDA (DRIBBLEFILE) (* ; "Edited 14-Feb-2026 00:42 by rmk")
(* ; "Edited 5-Feb-2026 10:26 by rmk")
(* ; "Edited 28-Dec-2025 12:06 by rmk")
(* ; "Edited 1-Sep-2025 11:59 by rmk")
(* ; "Edited 18-Aug-2025 12:09 by rmk")
@@ -78,7 +79,6 @@
(DIRECTORYNAME T)
T T) (* ; "For FONTSAVAILABLE lookup")
(LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT")
(LOADFULLFONTS)
(LISTPUT IDLE.PROFILE 'TIMEOUT 0)
(SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
@@ -88,6 +88,7 @@
GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT HELPSYS
DINFO CLIPBOARD MODERNIZE WHEELSCROLL PRETTYFILEINDEX WHO-LINE UNIXCOMM UNIXCHAT
UNIXYCD))
(LOADFULLFONTS)
(COND
((WINDOWP *WHO-LINE*)
(CLOSEW *WHO-LINE*)))
@@ -102,5 +103,5 @@
(FIXMETA)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (456 5820 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5570) (FIXMETA 5572 . 5818)))))
(FILEMAP (NIL (456 5929 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5679) (FIXMETA 5681 . 5927)))))
STOP

BIN
internal/loadups/LOADUP-FULL.LCOM
View File

Binary file not shown.

18
internal/loadups/LOADUP-LISP
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "28-Jan-2026 14:30:48" |{DSK}<Users>larry>IL>medley>internal>loadups>LOADUP-LISP.;2| 7369
(FILECREATED "22-Feb-2026 14:15:31" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;27| 7420
:EDIT-BY "lmm"
:EDIT-BY |rmk|
:CHANGES-TO (FNS LOADUP-LISP)
:PREVIOUS-DATE "27-Dec-2025 15:02:04"
|{DSK}<Users>larry>IL>medley>internal>loadups>LOADUP-LISP.;1|)
:PREVIOUS-DATE "22-Feb-2026 09:49:23" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;26|)
(PRETTYCOMPRINT LOADUP-LISPCOMS)
@@ -20,7 +19,8 @@
(DEFINEQ
(LOADUP-LISP
(LAMBDA (DRIBBLEFILE) (* \; "Edited 28-Jan-2026 14:30 by lmm")
(LAMBDA (DRIBBLEFILE) (* \; "Edited 22-Feb-2026 14:15 by rmk")
(* \; "Edited 28-Jan-2026 14:30 by lmm")
(* \; "Edited 27-Dec-2025 15:02 by rmk")
(* \; "Edited 16-Oct-2025 16:55 by rmk")
(* \; "Edited 18-Aug-2025 12:08 by rmk")
@@ -95,9 +95,9 @@
(* |;;| "Also, UNICODE is split into UNICODE-TABLES and UNICODE, so the tables are loaded before their MCCS/Uncode client functions are installed. Functions in UFS now depend on those translations so that filenames can have characters outside of Ascii. ")
(LOADUP '(UNICODE-TABLES UNICODE CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU
WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL
DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN))
(LOADUP '(CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU WINDOWOBJ WINDOWSCROLL
WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE
CMLARRAYINSPECTOR EDITINTERFACE TTYIN))
(LOADUP '(BREAK-AND-TRACE))
(LOADUP '(FASDUMP XCL-COMPILER ADVISE))
@@ -147,5 +147,5 @@
(GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST)
)
(DECLARE\: DONTCOPY
(FILEMAP (NIL (675 7163 (LOADUP-LISP 685 . 7161)))))
(FILEMAP (NIL (640 7214 (LOADUP-LISP 650 . 7212)))))
STOP

BIN
internal/loadups/LOADUP-LISP.LCOM
View File

Binary file not shown.

BIN
internal/loadups/starter.sysout
View File

Binary file not shown.

17
library/CLIPBOARD
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "25-Sep-2025 15:00:01" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>CLIPBOARD.;28 8305
(FILECREATED "23-Feb-2026 12:35:55" {WMEDLEY}<library>CLIPBOARD.;29 8228
:EDIT-BY rmk
:CHANGES-TO (FNS PUTCLIPBOARD CLIPBOARD-COPY-STREAM)
:CHANGES-TO (VARS CLIPBOARDCOMS)
:PREVIOUS-DATE "21-Apr-2024 09:12:04" {WMEDLEY}<library>CLIPBOARD.;18)
:PREVIOUS-DATE "25-Sep-2025 15:00:01" {WMEDLEY}<library>CLIPBOARD.;28)
(PRETTYCOMPRINT CLIPBOARDCOMS)
@@ -18,7 +17,7 @@
CLIPBOARD-PASTE-STREAM)
(FNS SEDIT.COPYTOCLIPBOARD)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD)
UNIXCOMM UNICODE)
UNIXCOMM)
(P (INSTALL-CLIPBOARD)))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
@@ -148,7 +147,7 @@
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY
(FILESLOAD (SYSLOAD)
UNIXCOMM UNICODE)
UNIXCOMM)
(INSTALL-CLIPBOARD)
@@ -162,7 +161,7 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1167 6486 (INSTALL-CLIPBOARD 1177 . 2504) (GETCLIPBOARD 2506 . 2880) (PUTCLIPBOARD 2882
. 4306) (PASTEFROMCLIPBOARD 4308 . 5226) (CLIPBOARD-COPY-STREAM 5228 . 5762) (CLIPBOARD-PASTE-STREAM
5764 . 6484)) (6487 8026 (SEDIT.COPYTOCLIPBOARD 6497 . 8024)))))
(FILEMAP (NIL (1098 6417 (INSTALL-CLIPBOARD 1108 . 2435) (GETCLIPBOARD 2437 . 2811) (PUTCLIPBOARD 2813
. 4237) (PASTEFROMCLIPBOARD 4239 . 5157) (CLIPBOARD-COPY-STREAM 5159 . 5693) (CLIPBOARD-PASTE-STREAM
5695 . 6415)) (6418 7957 (SEDIT.COPYTOCLIPBOARD 6428 . 7955)))))
STOP

BIN
library/CLIPBOARD.LCOM
View File

Binary file not shown.

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.

4682
library/sketch/SKETCH
View File

File diff suppressed because it is too large Load Diff

BIN
library/sketch/SKETCH.LCOM
View File

Binary file not shown.

88
library/virtualkeyboards/KEYBOARDCONFIGS
View File

@@ -1,10 +1,10 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
(FILECREATED "13-Oct-2025 13:44:47" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;5 59521
(FILECREATED "19-Feb-2026 22:32:05" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;6 59604
:EDIT-BY rmk
:PREVIOUS-DATE "13-Oct-2025 12:03:23" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;4)
:PREVIOUS-DATE "13-Oct-2025 13:44:47" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;5)
(PRETTYCOMPRINT KEYBOARDCONFIGSCOMS)
@@ -57,11 +57,11 @@
(F3 (F3 ITALIC))
(F4 (F4 UCASE))
(F5 (F5 STRIKE))
(F6 (F6 "­"))
(F6 (F6 "^"))
(F7 (F7 SUBSCR))
(F8 (F8 SMALL))
(F9 (F9 MARGIN))
(F10 (F10 "¬"))
(F10 (F10 "_"))
(F11 (F11 ""))
(F12 (F12 ""))
(LOCK ("CAPS" "LOCK"))
@@ -115,7 +115,7 @@
(THREE (|3| %# NLS))
(FOUR (|4| $ NLS))
(FIVE (|5| %% NLS))
(SIX (|6| ^ NLS))
(SIX (|6| ↑ NLS))
(SEVEN (|7| & NLS))
(EIGHT (|8| * NLS))
(NINE (|9| %( NLS))))
@@ -234,7 +234,7 @@
NIL
((%" (%' %" NLS))
(+ (= + NLS))
(- (- _ NLS))
(- (- ← NLS))
(%: (; %: NLS))
(< (%, < NLS))
(> (%. > NLS))
@@ -255,13 +255,13 @@
(NUMERIC/ (/ /))
(NUMERIC0 (INS |0| NLS))
(NUMERIC1 (END |1| NLS))
(NUMERIC2 (¯ |2| NLS))
(NUMERIC2 (↓ |2| NLS))
(NUMERIC3 (PGDN |3| NLS))
(NUMERIC4 (¬ |4| NLS))
(NUMERIC4 (_ |4| NLS))
(NUMERIC5 (|5| |5|))
(NUMERIC6 (® |6| NLS))
(NUMERIC6 (→ |6| NLS))
(NUMERIC7 (HOME |7| NLS))
(NUMERIC8 (­ |8| NLS))
(NUMERIC8 (^ |8| NLS))
(NUMERIC9 (PGUP |9| NLS))
(NUMERIC= (= =))
(RETURN (CR CR))
@@ -274,17 +274,17 @@
(F3 (ITALIC NOTITALIC NLS))
(F4 (UCASE LCASE NLS))
(F5 (STRIKEOUT NOTSTRIKEOUT NLS))
(F6 ("­" "­" NLS))
(F6 ("^" "^" NLS))
(F7 (SUBSCRIPT SUPERSCRIPT NLS))
(F8 (SMALLER LARGER NLS))
(F9 (MARGINS NOTMARGINS NLS))
(F10 ("¬" "¬" NLS))
(F10 ("_" "_" NLS))
(F11 (F11 NOTF11 NLS))
(F12 (F12 NOTF12 NLS)))
((%` 45 B)
(~ 45 T)
(|6| 2 B)
(^ 2 T)
(↑ 2 T)
(%% 0 T)
(|5| 0 B)
($ 1 T)
@@ -523,7 +523,7 @@
(> (346 46 29 33))
(%: (362 82 29 33))
(<-%| (426 82 63 33))
(^ (450 118 29 33))
(↑ (450 118 29 33))
(DEL (498 154 29 33))
(R (162 118 29 33))
(T (194 118 29 33))
@@ -556,7 +556,7 @@
(LF (LF LF))
(LOCK LOCKDOWN . LOCKUP)
(\ (\ %| NLS))
(^ (_ ^ NLS))
(↑ (← ↑ NLS))
({ (%[ { NLS))
(} (%] } NLS)))
((BLANK-MIDDLE 30)
@@ -643,8 +643,8 @@
(%: 43)
(CR 44)
(<-%| 44)
(_ 45)
(^ 45)
(← 45)
(↑ 45)
(r 48)
(R 48)
(t 49)
@@ -744,7 +744,7 @@
NIL
((%" (%' %" NLS))
(+ (= + NLS))
(- (- _ NLS))
(- (- ← NLS))
(ESC (ESC %| NLS))
(%: (; %: NLS))
(< (%, < NLS))
@@ -757,7 +757,7 @@
(~ (%` ~ NLS)))
((%` 45)
(~ 45)
(^ 2)
(↑ 2)
(|6| 2)
(w 18)
(W 18)
@@ -951,7 +951,7 @@
NIL
((%" (%' %" NLS))
(+ (= + NLS))
(- (- _ NLS))
(- (- ← NLS))
(%: (; %: NLS))
(< (%, < NLS))
(<-%| (CR CR))
@@ -962,21 +962,21 @@
(KEYBOARD METADOWN . METAUP)
(LOCK LOCKDOWN . LOCKUP)
(NEXT (2,22 2,62 NLS))
(NUMERIC* (NUMLK ´ NLS))
(NUMERIC* (NUMLK × NLS))
(NUMERIC+ (HELP 2,45 NLS))
(NUMERIC, (\ %, NLS))
(NUMERIC- (SCRL - NLS))
(NUMERIC. (%| 21 NLS))
(NUMERIC/ (BREAK ¸ NLS))
(NUMERIC/ (BREAK ÷ NLS))
(NUMERIC0 (INS |0| NLS))
(NUMERIC1 (END |1| NLS))
(NUMERIC2 (¯ |2| NLS))
(NUMERIC2 (↓ |2| NLS))
(NUMERIC3 (PGDN |3| NLS))
(NUMERIC4 (¬ |4| NLS))
(NUMERIC4 (_ |4| NLS))
(NUMERIC5 (% |5| NLS))
(NUMERIC6 (® |6| NLS))
(NUMERIC6 (→ |6| NLS))
(NUMERIC7 (HOME |7| NLS))
(NUMERIC8 (­ |8| NLS))
(NUMERIC8 (^ |8| NLS))
(NUMERIC9 (PGUP |9| NLS))
(%` (%` ~ NLS))
({ (%[ { NLS))
@@ -987,7 +987,7 @@
(|4| 1)
($ 1)
(|6| 2)
(^ 2)
(↑ 2)
(e 3)
(E 3)
(|7| 4)
@@ -1233,7 +1233,7 @@
(%. (%. > NLS))
(/ (/ ? NLS))
(\ (\ %| NLS))
(- (- _ NLS))
(- (- ← NLS))
(%` (%` ~ NLS))
(%[ (%[ { NLS))
(%] (%] } NLS))
@@ -1249,13 +1249,13 @@
(NUMERIC/ (/ /))
(NUMERIC0 (INS |0| NLS))
(NUMERIC1 (END |1| NLS))
(NUMERIC2 (¯ |2| NLS))
(NUMERIC2 (↓ |2| NLS))
(NUMERIC3 (PGDN |3| NLS))
(NUMERIC4 (¬ |4| NLS))
(NUMERIC4 (_ |4| NLS))
(NUMERIC5 (|5| |5|))
(NUMERIC6 (® |6| NLS))
(NUMERIC6 (→ |6| NLS))
(NUMERIC7 (HOME |7| NLS))
(NUMERIC8 (­ |8| NLS))
(NUMERIC8 (^ |8| NLS))
(NUMERIC9 (PGUP |9| NLS))
(NUMERICENTER (CR CR))
(RALT METADOWN . METAUP)
@@ -1264,11 +1264,11 @@
(F3 (ITALIC NOTITALIC NLS))
(F4 (UCASE LCASE NLS))
(F5 (STRIKEOUT NOTSTRIKEOUT NLS))
(F6 ("­" "­" NLS))
(F6 ("^" "^" NLS))
(F7 (SUBSCRIPT SUPERSCRIPT NLS))
(F8 (SMALLER LARGER NLS))
(F9 (MARGINS NOTMARGINS NLS))
(F10 ("¬" "¬" NLS))
(F10 ("_" "_" NLS))
(F11 (F11 NOTF11 NLS))
(F12 (F12 NOTF12 NLS)))
((%' 28 B)
@@ -1276,7 +1276,7 @@
(%, 27 B)
(< 27 T)
(- 10 B)
(_ 10 T)
(← 10 T)
(> 42 T)
(%. 42 B)
(/ 12 B)
@@ -1286,7 +1286,7 @@
(%# 16 T)
($ 1 T)
(%% 0 T)
(^ 4 T)
(↑ 4 T)
(* 53 T)
(%( 22 T)
(%) 8 T)
@@ -1494,7 +1494,7 @@
(M (370 42 29 29))
(; (402 42 29 29))
(%: (434 42 29 29))
(_ (466 42 29 29))
(← (466 42 29 29))
(RSHIFT (498 42 53 29))
(LINEFEED (554 42 29 29))
(CONTROL (106 74 53 29))
@@ -1559,7 +1559,7 @@
(ONE (|1| + NLS))
(TWO (|2| %" NLS))
(THREE (|3| * NLS))
(FOUR (|4| ‡ NLS))
(FOUR (|4| NLS))
(SIX (|6| & NLS))
(SEVEN (|7| / NLS))
(EIGHT (|8| %( NLS))
@@ -1567,7 +1567,7 @@
(%: (%. %: NLS))
(; (%, ; NLS))
(? (%' ? NLS))
(AUMLAUT (… „ NLS))
(AUMLAUT (  NLS))
(CAPSLOCK CTRLDOWN . CTRLUP)
(CONTROL LOCKDOWN . LOCKUP)
(CR (CR CR))
@@ -1591,10 +1591,10 @@
(NUMERIC8 (|8| |8|))
(NUMERIC9 (|9| |9|))
(NUMERIC= (= =))
(OUMLAUT (‚ ” NLS))
(UUMLAUT (Š <20> NLS))
(OUMLAUT (  NLS))
(UUMLAUT (  NLS))
(%[ (%] %[ NLS))
(_ (- _ NLS))
(← (- ← NLS))
({ (< { NLS))
(} (> } NLS)))
((HELP 0)
@@ -1658,7 +1658,7 @@
(%. 49)
(%: 49)
(- 50)
(_ 50)
(← 50)
(RSHIFT 51)
(LINEFEED 52)
(CONTROL 53)

BIN
library/virtualkeyboards/XKEYBOARDS
View File

Binary file not shown.

303
lispusers/ISO8859IO
View File

@@ -1,26 +1,27 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Feb-2026 13:03:18" {WMEDLEY}<lispusers>ISO8859IO.;19 23459
(FILECREATED "22-Feb-2026 12:22:12" {WMEDLEY}<lispusers>ISO8859IO.;22 21861
:EDIT-BY rmk
:CHANGES-TO (FNS \MAKERECODEMAP MAKEISOFORMAT \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN)
:CHANGES-TO (FNS ISO1TOMSTRING MTOISO1STRING)
(VARS ISO8859IOCOMS)
:PREVIOUS-DATE " 8-Aug-2021 13:22:31" {WMEDLEY}<lispusers>ISO8859IO.;11)
:PREVIOUS-DATE " 2-Feb-2026 23:20:20" {WMEDLEY}<lispusers>ISO8859IO.;20)
(PRETTYCOMPRINT ISO8859IOCOMS)
(RPAQQ ISO8859IOCOMS
(
(* ;; "This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding.")
(* ;; "This package defines EXTERNALFORMATS for files that are encoded in ISIO8859/1, the standard IBM extended ascii, or the legacy MAC encoding.")
(COMS (* ; "ISO8859/1")
(FNS \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN)
(GLOBALVARS *MCCSTOISO8859MAP* *ISO8859TOMCCSMAP*)
(FNS MAKEISOFORMAT)
(P (MAKEISOFORMAT)))
[COMS (* ; "ISO8859/1")
(FNS ISO1TOMCODE MTOISO1CODE \CREATE.ISO1.FORMAT)
(FNS ISO1TOMSTRING MTOISO1STRING)
(VARS ISO1TOMCCS)
(GLOBALVARS ISO1TOMCCS)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.ISO1.FORMAT]
(COMS (* ; "IBM-PC Extended Ascii")
(FNS \IBMOUTCHARFN \IBMINCCODEFN \IBMPEEKCCODEFN)
(GLOBALVARS *XEROXTOIBMMAP* *IBMTOXEROXMAP*)
@@ -37,7 +38,7 @@
(* ;;
"This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding."
"This package defines EXTERNALFORMATS for files that are encoded in ISIO8859/1, the standard IBM extended ascii, or the legacy MAC encoding."
)
@@ -47,152 +48,150 @@
(DEFINEQ
(\8859OUTCHARFN
[LAMBDA (STREAM CHARCODE)
(DECLARE (GLOBALVARS *XEROXTOISO8859MAP*)) (* ; "Edited 1-Feb-2026 10:11 by rmk")
(* ; "Edited 8-Aug-2021 13:21 by rmk:")
(* ; "Edited 7-Dec-95 14:34 by ")
(* ; "Edited 7-Dec-95 14:32 by ")
(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")
(* ;; "Converts CHARCODE from internal encoding to ISO8859 before printing.")
(* ;; "ISO codes are 8bit, MCODES maybe not. Caller shouldn't pass a fat code.")
(* ;; "Unconverted codes are left unchanged (no error).")
(OR [CAR (find PAIR in ISO1TOMCCS suchthat (EQ ICODE (CADR PAIR]
ICODE])
(* ;; "If any remaining codes are out of charset 0, the streams external format will be used. ")
(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])
(IF (EQ CHARCODE (CHARCODE EOL))
THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
(\BOUTEOL STREAM)
ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM)
(IPLUS16 1 DATUM))
(\BOUT STREAM (IF (IGREATERP CHARCODE 127)
THEN
(* ;; "We know that ISO doesn't have floating accents, so only singletons are returned. We also know that it agrees with MCCS on first 128, except for cirumflex and underscore")
(\RECODECCODE CHARCODE *MCCSTOISO8859MAP*)
ELSE CHARCODE])
(\8859INCCODEFN
[LAMBDA (STRM COUNTP) (* ; "Edited 1-Feb-2026 10:10 by rmk")
(* ; "Edited 6-Aug-2021 16:10 by rmk:")
(* ; "Edited 7-Dec-95 15:24 by ")
(* ; "Edited 7-Dec-95 15:19 by ")
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1))
(\RECODECCODE (\BIN STRM)
*ISO8859TOMCCSMAP*])
(\8859PEEKCCODEFN
[LAMBDA (STRM NOERROR) (* ; "Edited 1-Feb-2026 10:10 by rmk")
(* ; "Edited 5-May-2021 17:44 by rmk:")
(* ; "Edited 3-Jan-96 14:21 by ")
(* ; "Edited 7-Dec-95 15:51 by ")
(* ; "Edited 7-Dec-95 15:19 by ")
(\RECODECCODE (\PEEKCCODE STRM NOERROR)
*ISO8859TOMCCSMAP*])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *MCCSTOISO8859MAP* *ISO8859TOMCCSMAP*)
)
(DEFINEQ
(MAKEISOFORMAT
[LAMBDA NIL (* ; "Edited 1-Feb-2026 11:18 by rmk")
(\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 ")
(LET [(MCCSTOISO '(("0,255" "0,136")
("0,254" "0,137")
("357,41" "0,240")
("357,153" "0,246")
("43,42" "0,250")
("0,323" "0,251")
("0,343" "0,252")
("357,152" "0,254")
("357,43" "0,255")
("0,322" "0,256")
("43,176" "0,257")
("43,47" "0,264")
("0,313" "0,270")
("0,321" "0,271")
("0,353" "0.272")
("361,41" "0,300")
("361,42" "0,301")
("361,43" "0,302")
("361,44" "0,303")
("361,47" "0,304")
("361,50" "0,305")
("0,341" "0,306")
("361,55" "0,307")
("361,60" "0,310")
("361,61" "0,311")
("361,62" "0,312")
("361,65" "0,313")
("361,76" "0,314")
("361,77" "0,315")
("361,100" "0,316")
("361,104" "0,317")
("0,342" "0,320")
("361,114" "0,321")
("361,117" "0,322")
("361,120" "0,323")
("361,121" "0,324")
("361,122" "0,325")
("361,124" "0,326")
("0,264" "0,327")
("0,351" "0,330")
("361,137" "0,331")
("361,140" "0,332")
("361,141" "0,333")
("361,145" "0,334")
("361,153" "0,335")
("0,354" "0,336")
("0,373" "0,337")
("361,241" "0,340")
("361,242" "0,341")
("361,243" "0,342")
("361,244" "0,343")
("361,247" "0,344")
("361,250" "0,345")
("0,361" "0,346")
("361,255" "0,347")
("361,260" "0,350")
("361,261" "0,351")
("361,262" "0,352")
("361,265" "0,353")
("361,276" "0,354")
("361,277" "0,355")
("361,300" "0,356")
("361,304" "0,357")
("0,363" "0,360")
("361,314" "0,361")
("361,317" "0,362")
("361,320" "0,363")
("361,321" "0,364")
("361,322" "0,365")
("361,324" "0,366")
("0,270" "0,367")
("0,371" "0,370")
("361,337" "0,371")
("361,340" "0,372")
("361,341" "0,373")
("361,345" "0,374")
("361,353" "0,375")
("0,374" "0,376")
("361,355" "0,377")
("361,155" "Meta,170"]
(SETQ *MCCSTOISO8859MAP* (\MAKERECODEMAP MCCSTOISO))
(SETQ *ISO8859TOMCCSMAP* (\MAKERECODEMAP MCCSTOISO T)))
(MAKE-EXTERNALFORMAT :ISO8859/1 (FUNCTION \8859INCCODEFN)
(FUNCTION \8859PEEKCCODEFN)
(FUNCTION \COMMONBACKCCODEFN)
(FUNCTION \8859OUTCHARFN])
(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])
)
(DEFINEQ
(ISO1TOMSTRING
[LAMBDA (ISTRING DESTRUCTIVE) (* ; "Edited 22-Feb-2026 12:21 by rmk")
(* ; "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 22-Feb-2026 12:22 by rmk")
(* ; "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])
)
(MAKEISOFORMAT)
(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)
)
@@ -553,10 +552,10 @@
(* ; "Edited 21-Jun-95 10:18 by rmk:")
(* ;; "Recodes a singleton charcode. Leaves everything else unchanged.")
(LET [(CSMAP (CL:SVREF MAPARRAY (LRSH CODE 8]
(OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255)))
CODE])
)
(DECLARE%: DONTCOPY
(LET [(CSMAP (CL:SVREF MAPARRAY (LRSH CODE 8]
(OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255)))
CODE])
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1834 4154 (ISO1TOMCODE 1844 . 2593) (MTOISO1CODE 2595 . 2885) (\CREATE.ISO1.FORMAT 2887

BIN
lispusers/ISO8859IO.LCOM
View File

Binary file not shown.

1
scripts/loadups/loadup-init.sh
View File

@@ -8,6 +8,7 @@ main() {
cmfile="-"
cat >"${initfile}" <<-"EOF"
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
(* "make init files; this file is loaded as a 'greet' file by scripts/loadup-init.sh")
(SETQ MEDLEYDIR NIL)

196
sources/ADISPLAY
View File

@@ -1,14 +1,10 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
(FILECREATED " 8-Jul-2025 20:19:58" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>ADISPLAY.;14 244883
(FILECREATED "19-Feb-2026 12:09:16" {WMEDLEY}<sources>ADISPLAY.;15 244850
:EDIT-BY rmk
:CHANGES-TO (VARS ADISPLAYCOMS)
:PREVIOUS-DATE "19-Dec-2023 11:23:08"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>ADISPLAY.;13)
:PREVIOUS-DATE " 8-Jul-2025 20:19:58" {WMEDLEY}<sources>ADISPLAY.;14)
(PRETTYCOMPRINT ADISPLAYCOMS)
@@ -130,7 +126,7 @@
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
(RECORD REGION (LEFT BOTTOM WIDTH HEIGHT)
LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767
LEFT ← -16383 BOTTOM ← -16383 WIDTH ← 32767 HEIGHT ← 32767
[ACCESSFNS ((TOP (IPLUS (fetch (REGION BOTTOM) of DATUM)
(fetch (REGION HEIGHT) of DATUM)
-1))
@@ -150,7 +146,7 @@
(BITMAPHEIGHT WORD)
(BITMAPWIDTH WORD)
(BITMAPBITSPERPIXEL WORD))
BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD)
BITMAPBITSPERPIXEL ← 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD)
(BitMapLoLoc WORD))
(* ; "overlay initial pointer")
)
@@ -398,7 +394,7 @@
(T (printout T "******** " BITMAP " is not a BITMAP." T)
(RETURN NIL)))
(printout FILE "(" .P2 (BITMAPWIDTH BM)
%, .P2 (BITMAPHEIGHT BM)) (* ;
%, .P2 (BITMAPHEIGHT BM)) (* ;
 "if the number of bits per pixel is not 1, write it out.")
(COND
((NEQ (BITSPERPIXEL BM)
@@ -431,7 +427,7 @@
(* ;; "Print this bitmap in the preferred way.")
(LET* ((WIDTH (BITMAPWIDTH BITMAP))
(HEIGHT (BITMAPHEIGHT BITMAP))
(HEIGHT (BITMAPHEIGHT BITMAP))
(BITS-PER-PIXEL (BITSPERPIXEL BITMAP))
(BASE (fetch BITMAPBASE of BITMAP))
(QUAD-CHARS-PER-ROW (FOLDHI (CL:* WIDTH BITS-PER-PIXEL)
@@ -712,20 +708,20 @@
NIL)
((CURSORP DEFAULTCARET)
(create CARET1
CURSOR _ DEFAULTCARET))
CURSOR ← DEFAULTCARET))
(T (ERROR "DEFAULTCARET is not a cursor"
DEFAULTCARET))))
(OFF NIL)
(COND
((CURSORP NEWCARET)
(create CARET1
CURSOR _ NEWCARET))
CURSOR ← NEWCARET))
(T (LISPERROR "ILLEGAL ARG" NEWCARET])])
(\CARET.CREATE
[LAMBDA (CURSOR) (* jds "11-Jul-85 19:38")
(create CARET1
CURSOR _ (OR CURSOR DEFAULTCARET])
CURSOR ← (OR CURSOR DEFAULTCARET])
(\CARET.DOWN
[LAMBDA (STREAM INTERVAL UNLESSOCCLUDED) (* lmm " 4-May-84 18:15")
@@ -815,7 +811,7 @@
(LET ((OCARET \CARET.UP))
(COND
([AND OCARET CARET (DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM]
(for (OC _ OCARET) by (fetch (CARET1 NEXT) of OC)
(for (OC ← OCARET) by (fetch (CARET1 NEXT) of OC)
do (COND
[(NULL OC)
(RETURN (COND
@@ -1008,10 +1004,10 @@
[LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* rrb "17-JUN-83 08:56")
(* ; "creates a region structure.")
(create REGION
LEFT _ LEFT
BOTTOM _ BOTTOM
WIDTH _ WIDTH
HEIGHT _ HEIGHT])
LEFT ← LEFT
BOTTOM ← BOTTOM
WIDTH ← WIDTH
HEIGHT ← HEIGHT])
(REGIONP
[LAMBDA (X) (* rrb "29-Jun-84 18:00")
@@ -1029,11 +1025,11 @@
(* ;; "this is documented as returning a very large region. This one covers the entire FIXP range so should work for many purposes. rrb")
(create REGION
LEFT _ (SUB1 MIN.FIXP)
BOTTOM _ (SUB1 MIN.FIXP)
WIDTH _ (PLUS (TIMES 2 MAX.FIXP)
LEFT ← (SUB1 MIN.FIXP)
BOTTOM ← (SUB1 MIN.FIXP)
WIDTH ← (PLUS (TIMES 2 MAX.FIXP)
4)
HEIGHT _ (PLUS (TIMES 2 MAX.FIXP)
HEIGHT ← (PLUS (TIMES 2 MAX.FIXP)
4)))
(T (PROG (REG LFT RGHT BTTM TP)
(SETQ REG (ARG REGIONS 1))
@@ -1062,10 +1058,10 @@
((AND (IGEQ RGHT LFT)
(IGEQ TP BTTM))
(create REGION
LEFT _ LFT
BOTTOM _ BTTM
WIDTH _ (ADD1 (IDIFFERENCE RGHT LFT))
HEIGHT _ (ADD1 (IDIFFERENCE TP BTTM])
LEFT ← LFT
BOTTOM ← BTTM
WIDTH ← (ADD1 (IDIFFERENCE RGHT LFT))
HEIGHT ← (ADD1 (IDIFFERENCE TP BTTM])
(UNIONREGIONS
[LAMBDA REGIONS (* rrb "30-Dec-85 17:07")
@@ -1099,10 +1095,10 @@
TP)
(SETQ TP (fetch (REGION PTOP) of REG]
(RETURN (create REGION
LEFT _ LFT
BOTTOM _ BTTM
WIDTH _ (DIFFERENCE RGHT LFT)
HEIGHT _ (DIFFERENCE TP BTTM])
LEFT ← LFT
BOTTOM ← BTTM
WIDTH ← (DIFFERENCE RGHT LFT)
HEIGHT ← (DIFFERENCE TP BTTM])
(REGIONSINTERSECTP
[LAMBDA (REGION1 REGION2) (* rrb "16-AUG-81 08:29")
@@ -1233,11 +1229,11 @@
(* ;; "returns the region taken up by STR if it were printed at the current position of STREAM")
(create REGION
LEFT _ (DSPXPOSITION NIL STREAM)
BOTTOM _ (IDIFFERENCE (DSPYPOSITION NIL STREAM)
LEFT ← (DSPXPOSITION NIL STREAM)
BOTTOM ← (IDIFFERENCE (DSPYPOSITION NIL STREAM)
(FONTPROP STREAM 'DESCENT))
WIDTH _ (STRINGWIDTH STR STREAM PRIN2FLG RDTBL)
HEIGHT _ (FONTPROP STREAM 'HEIGHT])
WIDTH ← (STRINGWIDTH STR STREAM PRIN2FLG RDTBL)
HEIGHT ← (FONTPROP STREAM 'HEIGHT])
)
@@ -1443,8 +1439,8 @@
(SETQ BRUSHARRAY (ARRAY 16 'POINTER NIL 1))
(for X from 1 to 16 do (SETA BRUSHARRAY X (APPLY* BRUSHFN X]
(push \BrushAList (CONS BRUSHNAME (create BRUSHITEM
BRUSHARRAY _ BRUSHARRAY
CREATEMETHOD _ BRUSHFN)))
BRUSHARRAY ← BRUSHARRAY
CREATEMETHOD ← BRUSHFN)))
(push KNOWN.BRUSHES BRUSHNAME])
)
@@ -1506,12 +1502,12 @@
CBottom)
(SETQ BITMAP (ffetch DDDestination of DD))
(SETQ BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP))
(SETQ HEIGHT (BITMAPHEIGHT BITMAP))
(SETQ HEIGHT (BITMAPHEIGHT BITMAP))
(SETQ ClippingTop (ffetch DDClippingTop of DD))
(SETQ ClippingBottom (ffetch DDClippingBottom of DD))
(SETQ BM (GetNewFragment BIGBMLIST))
(while (AND BM (IGREATERP HEIGHT ClippingBottom))
do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
[SETQ CTop (COND
((IGREATERP ClippingTop HEIGHT)
(IDIFFERENCE HEIGHT BOTTOM))
@@ -1576,7 +1572,7 @@
(SUB1 (ffetch DDClippingTop of DD))
DISPLAYSTREAM COLOR))
(T (PROG ((BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP))
(HEIGHT (BITMAPHEIGHT BITMAP))
(HEIGHT (BITMAPHEIGHT BITMAP))
BOTTOM BM CTop CBottom (ClippingTop (ffetch DDClippingTop of DD))
(ClippingBottom (ffetch DDClippingBottom of DD))
(YY1 (\DSPTRANSFORMY (OR (FIXP Y1)
@@ -1587,7 +1583,7 @@
DD)))
(SETQ BM (GetNewFragment BIGBMLIST))
(while (AND BM (IGREATERP HEIGHT ClippingBottom))
do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
[SETQ CTop (COND
((IGREATERP ClippingTop HEIGHT)
(IDIFFERENCE HEIGHT BOTTOM))
@@ -2038,7 +2034,7 @@
(DECLARE%: EVAL@COMPILE
(PUTPROPS .DRAWLINEX. MACRO [(MODE)
(bind (NY _ 0) for PT from 1 to PIXELSINX
(bind (NY ← 0) for PT from 1 to PIXELSINX
do (* ; "main loop")
[replace (BITMAPWORD BITS) of FIRSTADDR
with (SELECTQ MODE
@@ -2068,7 +2064,7 @@
(SETQ MASK 32768])
(PUTPROPS .DRAWLINEY. MACRO [(MODE)
(bind (NX _ 0) for PT from 1 to PIXELSINY
(bind (NX ← 0) for PT from 1 to PIXELSINY
do (* ; "main loop")
[replace (BITMAPWORD BITS) of FIRSTADDR
with (SELECTQ MODE
@@ -2295,9 +2291,9 @@
(RETURN (for ANGLE from STARTANGLE to (PLUS STARTANGLE ANGLESIZE (QUOTIENT ANGLEINCR 5.0))
by ANGLEINCR collect (create POSITION
XCOORD _ [FIXR (PLUS CENTERX (TIMES RADIUS
XCOORD ← [FIXR (PLUS CENTERX (TIMES RADIUS
(COS ANGLE]
YCOORD _ (FIXR (PLUS CENTERY (TIMES RADIUS
YCOORD ← (FIXR (PLUS CENTERY (TIMES RADIUS
(SIN ANGLE])
(\DRAWELLIPSE.DISPLAY
@@ -2609,7 +2605,7 @@
((EQ (fetch (BRUSH BRUSHSHAPE) of BRUSH)
'ROUND)
BRUSH)
(T (create BRUSH using BRUSH BRUSHSHAPE _ 'ROUND]
(T (create BRUSH using BRUSH BRUSHSHAPE ← 'ROUND]
(SETQ COLOR (fetch (BRUSH BRUSHCOLOR) of PTBRUSH))
(for PTAIL on POINTS while (CDR PTAIL) do (\DRAWLINE.DISPLAY STREAM (fetch (POSITION XCOORD
)
@@ -2991,15 +2987,15 @@
(ELT DDY I]
(SETQ SPLINE
(create SPLINE
%#KNOTS _ %#KNOTS
SPLINEX _ X
SPLINEY _ Y
SPLINEDX _ DX
SPLINEDY _ DY
SPLINEDDX _ DDX
SPLINEDDY _ DDY
SPLINEDDDX _ DDDX
SPLINEDDDY _ DDDY))
%#KNOTS ← %#KNOTS
SPLINEX ← X
SPLINEY ← Y
SPLINEDX ← DX
SPLINEDY ← DY
SPLINEDDX ← DDX
SPLINEDDY ← DDY
SPLINEDDDX ← DDDX
SPLINEDDDY ← DDDY))
(RETURN SPLINE])
(\CURVE
@@ -3187,7 +3183,7 @@
(SETQ POINTSPERSEG 64)
(SETQ NPOINTS (UNFOLD NSEGS 64]
(SETQ D1 (FQUOTIENT 1.0 NPOINTS)) (* ;
 "Set up ÿ&Eÿt, ÿ&Eÿt**2 and ÿ&Eÿt**3, for computing the next point.")
 "Set up Δt, Δt**2 and Δt**3, for computing the next point.")
(SETQ D2 (FTIMES D1 D1))
(SETQ D3 (FTIMES D2 D1))
(SETQ D3X (FTIMES D3 DDDX))
@@ -3219,11 +3215,11 @@
(SETQ PERSEG (FQUOTIENT 1.0 NSEGS))
(LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0)
(LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0)
(bind (TT _ 0.0)
(DDDX/PER/SEG _ (FTIMES DDDX PERSEG))
(DDDY/PER/SEG _ (FTIMES DDDY PERSEG))
[D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0]
[D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I
(bind (TT ← 0.0)
(DDDX/PER/SEG ← (FTIMES DDDX PERSEG))
(DDDY/PER/SEG ← (FTIMES DDDY PERSEG))
[D3XFACTOR ← (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0]
[D3YFACTOR ← (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I
from 0 to (SUB1 NSEGS)
do
(* ;;
@@ -4224,9 +4220,9 @@
(SETQ Min (FDIFFERENCE (FTIMES L 2)
Max))
(RETURN (create RGB
RED _ (\HLSVALUEFN Min Max H)
GREEN _ (\HLSVALUEFN Min Max (IDIFFERENCE H 120))
BLUE _ (\HLSVALUEFN Min Max (IDIFFERENCE H 240])
RED ← (\HLSVALUEFN Min Max H)
GREEN ← (\HLSVALUEFN Min Max (IDIFFERENCE H 120))
BLUE ← (\HLSVALUEFN Min Max (IDIFFERENCE H 240])
(\HLSVALUEFN
[LAMBDA (MIN MAX HUE) (* rrb "25-OCT-82 10:47")
@@ -4424,40 +4420,40 @@
(ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (10589 10783 (SCREENREGIONP 10599 . 10781)) (12227 19588 (\BBTCURVEPT 12237 . 19586)) (
19589 29405 (CREATETEXTUREFROMBITMAP 19599 . 21529) (PRINTBITMAP 21531 . 22882) (PRINT-BITMAPS-NICELY
22884 . 26735) (PRINTCURSOR 26737 . 27770) (\WRITEBITMAP 27772 . 29403)) (29448 31996 (\GETINTEGERPART
29458 . 31003) (\CONVERTTOFRACTION 31005 . 31994)) (32133 33005 (CURSORP 32143 . 32362) (CURSORBITMAP
32364 . 32410) (CreateCursorBitMap 32412 . 33003)) (37367 46290 (CARET 37377 . 39137) (\CARET.CREATE
39139 . 39317) (\CARET.DOWN 39319 . 40671) (\CARET.FLASH? 40673 . 42367) (\CARET.SHOW 42369 . 42938) (
CARETRATE 42940 . 43598) (\CARET.FLASH.AGAIN 43600 . 44766) (\CARET.FLASH.MULTIPLE 44768 . 45291) (
\CARET.FLASH 45293 . 46288)) (46291 51363 (\MEDW.CARET.SHOW 46301 . 51361)) (51727 53562 (
\AREAVISIBLE? 51737 . 52661) (\REGIONOVERLAPAREAP 52663 . 53208) (\AREAINREGIONP 53210 . 53560)) (
53611 66087 (CREATEREGION 53621 . 53957) (REGIONP 53959 . 54105) (INTERSECTREGIONS 54107 . 56877) (
UNIONREGIONS 56879 . 59030) (REGIONSINTERSECTP 59032 . 59640) (SUBREGIONP 59642 . 60287) (EXTENDREGION
60289 . 62446) (EXTENDREGIONBOTTOM 62448 . 63090) (EXTENDREGIONLEFT 63092 . 63711) (EXTENDREGIONRIGHT
63713 . 64266) (EXTENDREGIONTOP 64268 . 64809) (INSIDEP 64811 . 65579) (STRINGREGION 65581 . 66085))
(66332 71606 (\BRUSHBITMAP 66342 . 68059) (\GETBRUSH 68061 . 68372) (\GETBRUSHBBT 68374 . 70402) (
\InitCurveBrushes 70404 . 71470) (\BrushFromWidth 71472 . 71604)) (71607 74674 (\MAKEBRUSH.DIAGONAL
71617 . 71897) (\MAKEBRUSH.HORIZONTAL 71899 . 72293) (\MAKEBRUSH.VERTICAL 72295 . 72607) (
\MAKEBRUSH.SQUARE 72609 . 72886) (\MAKEBRUSH.ROUND 72888 . 74672)) (74675 75840 (INSTALLBRUSH 74685 .
75838)) (76241 87643 (\DRAWLINE.DISPLAY 76251 . 86358) (RELMOVETO 86360 . 86747) (MOVETOUPPERLEFT
86749 . 87641)) (87644 111129 (\CLIPANDDRAWLINE 87654 . 94100) (\CLIPANDDRAWLINE1 94102 . 105850) (
\CLIPCODE 105852 . 107226) (\LEASTPTAT 107228 . 107826) (\GREATESTPTAT 107828 . 108456) (\DRAWLINE1
108458 . 109574) (\DRAWLINE.UFN 109576 . 111127)) (115659 161706 (\DRAWCIRCLE.DISPLAY 115669 . 124482)
(\DRAWARC.DISPLAY 124484 . 124774) (\DRAWARC.GENERIC 124776 . 125529) (\COMPUTE.ARC.POINTS 125531 .
127796) (\DRAWELLIPSE.DISPLAY 127798 . 143467) (\DRAWCURVE.DISPLAY 143469 . 145758) (
\DRAWPOINT.DISPLAY 145760 . 146956) (\DRAWPOLYGON.DISPLAY 146958 . 150486) (\LINEWITHBRUSH 150488 .
161704)) (161707 193399 (LOADPOLY 161717 . 162277) (PARAMETRICSPLINE 162279 . 172476) (\CURVE 172478
. 178080) (\CURVE2 178082 . 189413) (\CURVEEND 189415 . 189897) (\CURVESLOPE 189899 . 192382) (
\CURVESTART 192384 . 192708) (\FDIFS/FROM/DERIVS 192710 . 193397)) (205928 220264 (\FILLCIRCLE.DISPLAY
205938 . 216686) (\LINEBLT 216688 . 220262)) (220308 221930 (SCREENBITMAP 220318 . 220795) (BITMAPP
220797 . 221031) (BITSPERPIXEL 221033 . 221928)) (222571 223564 (DSPFILL 222581 . 223264) (INVERTW
223266 . 223562)) (223565 227208 (\DSPCOLOR.DISPLAY 223575 . 224872) (\DSPBACKCOLOR.DISPLAY 224874 .
226253) (DSPEOLFN 226255 . 227206)) (227641 232295 (DSPCLEOL 227651 . 228527) (DSPRUBOUTCHAR 228529 .
228961) (\DSPMOVELR 228963 . 232293)) (232425 233543 (\CURSOR.DEFPRINT 232435 . 233541)) (233955
242529 (TEXTUREOFCOLOR 233965 . 235227) (\PRIMARYTEXTURE 235229 . 235811) (\LEVELTEXTURE 235813 .
236314) (INSURE.B&W.TEXTURE 236316 . 237711) (INSURE.RGB.COLOR 237713 . 239141) (\LOOKUPCOLORNAME
239143 . 239413) (RGBP 239415 . 240180) (HLSP 240182 . 240557) (HLSTORGB 240559 . 241699) (\HLSVALUEFN
241701 . 242527)))))
(FILEMAP (NIL (10493 10687 (SCREENREGIONP 10503 . 10685)) (12131 19492 (\BBTCURVEPT 12141 . 19490)) (
19493 29301 (CREATETEXTUREFROMBITMAP 19503 . 21433) (PRINTBITMAP 21435 . 22782) (PRINT-BITMAPS-NICELY
22784 . 26631) (PRINTCURSOR 26633 . 27666) (\WRITEBITMAP 27668 . 29299)) (29344 31892 (\GETINTEGERPART
29354 . 30899) (\CONVERTTOFRACTION 30901 . 31890)) (32029 32901 (CURSORP 32039 . 32258) (CURSORBITMAP
32260 . 32306) (CreateCursorBitMap 32308 . 32899)) (37263 46194 (CARET 37273 . 39037) (\CARET.CREATE
39039 . 39219) (\CARET.DOWN 39221 . 40573) (\CARET.FLASH? 40575 . 42269) (\CARET.SHOW 42271 . 42840) (
CARETRATE 42842 . 43500) (\CARET.FLASH.AGAIN 43502 . 44670) (\CARET.FLASH.MULTIPLE 44672 . 45195) (
\CARET.FLASH 45197 . 46192)) (46195 51267 (\MEDW.CARET.SHOW 46205 . 51265)) (51631 53466 (
\AREAVISIBLE? 51641 . 52565) (\REGIONOVERLAPAREAP 52567 . 53112) (\AREAINREGIONP 53114 . 53464)) (
53515 66031 (CREATEREGION 53525 . 53869) (REGIONP 53871 . 54017) (INTERSECTREGIONS 54019 . 56805) (
UNIONREGIONS 56807 . 58966) (REGIONSINTERSECTP 58968 . 59576) (SUBREGIONP 59578 . 60223) (EXTENDREGION
60225 . 62382) (EXTENDREGIONBOTTOM 62384 . 63026) (EXTENDREGIONLEFT 63028 . 63647) (EXTENDREGIONRIGHT
63649 . 64202) (EXTENDREGIONTOP 64204 . 64745) (INSIDEP 64747 . 65515) (STRINGREGION 65517 . 66029))
(66276 71550 (\BRUSHBITMAP 66286 . 68003) (\GETBRUSH 68005 . 68316) (\GETBRUSHBBT 68318 . 70346) (
\InitCurveBrushes 70348 . 71414) (\BrushFromWidth 71416 . 71548)) (71551 74618 (\MAKEBRUSH.DIAGONAL
71561 . 71841) (\MAKEBRUSH.HORIZONTAL 71843 . 72237) (\MAKEBRUSH.VERTICAL 72239 . 72551) (
\MAKEBRUSH.SQUARE 72553 . 72830) (\MAKEBRUSH.ROUND 72832 . 74616)) (74619 75788 (INSTALLBRUSH 74629 .
75786)) (76189 87575 (\DRAWLINE.DISPLAY 76199 . 86290) (RELMOVETO 86292 . 86679) (MOVETOUPPERLEFT
86681 . 87573)) (87576 111061 (\CLIPANDDRAWLINE 87586 . 94032) (\CLIPANDDRAWLINE1 94034 . 105782) (
\CLIPCODE 105784 . 107158) (\LEASTPTAT 107160 . 107758) (\GREATESTPTAT 107760 . 108388) (\DRAWLINE1
108390 . 109506) (\DRAWLINE.UFN 109508 . 111059)) (115595 161648 (\DRAWCIRCLE.DISPLAY 115605 . 124418)
(\DRAWARC.DISPLAY 124420 . 124710) (\DRAWARC.GENERIC 124712 . 125465) (\COMPUTE.ARC.POINTS 125467 .
127736) (\DRAWELLIPSE.DISPLAY 127738 . 143407) (\DRAWCURVE.DISPLAY 143409 . 145698) (
\DRAWPOINT.DISPLAY 145700 . 146896) (\DRAWPOLYGON.DISPLAY 146898 . 150428) (\LINEWITHBRUSH 150430 .
161646)) (161649 193360 (LOADPOLY 161659 . 162219) (PARAMETRICSPLINE 162221 . 172436) (\CURVE 172438
. 178040) (\CURVE2 178042 . 189374) (\CURVEEND 189376 . 189858) (\CURVESLOPE 189860 . 192343) (
\CURVESTART 192345 . 192669) (\FDIFS/FROM/DERIVS 192671 . 193358)) (205889 220225 (\FILLCIRCLE.DISPLAY
205899 . 216647) (\LINEBLT 216649 . 220223)) (220269 221891 (SCREENBITMAP 220279 . 220756) (BITMAPP
220758 . 220992) (BITSPERPIXEL 220994 . 221889)) (222532 223525 (DSPFILL 222542 . 223225) (INVERTW
223227 . 223523)) (223526 227169 (\DSPCOLOR.DISPLAY 223536 . 224833) (\DSPBACKCOLOR.DISPLAY 224835 .
226214) (DSPEOLFN 226216 . 227167)) (227602 232256 (DSPCLEOL 227612 . 228488) (DSPRUBOUTCHAR 228490 .
228922) (\DSPMOVELR 228924 . 232254)) (232386 233504 (\CURSOR.DEFPRINT 232396 . 233502)) (233916
242496 (TEXTUREOFCOLOR 233926 . 235188) (\PRIMARYTEXTURE 235190 . 235772) (\LEVELTEXTURE 235774 .
236275) (INSURE.B&W.TEXTURE 236277 . 237672) (INSURE.RGB.COLOR 237674 . 239102) (\LOOKUPCOLORNAME
239104 . 239374) (RGBP 239376 . 240141) (HLSP 240143 . 240518) (HLSTORGB 240520 . 241666) (\HLSVALUEFN
241668 . 242494)))))
STOP

BIN
sources/ADISPLAY.LCOM
View File

Binary file not shown.

80
sources/ATBL
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "24-Apr-2025 21:52:35" {WMEDLEY}<sources>ATBL.;33 91754
(FILECREATED "25-Feb-2026 12:02:51" {WMEDLEY}<sources>ATBL.;35 92262
:EDIT-BY rmk
:CHANGES-TO (FNS \ATBLSET EQUAL-READER-ENVIRONMENT)
:CHANGES-TO (VARS ATBLCOMS)
:PREVIOUS-DATE "26-Dec-2021 14:32:50" {WMEDLEY}<sources>ATBL.;32)
:PREVIOUS-DATE "24-Apr-2025 21:52:35" {WMEDLEY}<sources>ATBL.;33)
(PRETTYCOMPRINT ATBLCOMS)
@@ -56,12 +56,13 @@
(CONSTANTS * READCLASSES)
(CONSTANTS * READMACROWAKEUPS)
(CONSTANTS * READMACROESCAPES)
(RECORDS READCODE READMACRODEF READTABLEP))
(RECORDS READCODE READMACRODEF READTABLEP)
(RECORDS READER-ENVIRONMENT))
(GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE))
(INITRECORDS READTABLEP))
(INITRECORDS READTABLEP)
(INITRECORDS READER-ENVIRONMENT))
[COMS (INITVARS (\READTABLEHASH))
(FNS \ATBLSET)
(INITRECORDS READER-ENVIRONMENT)
(* ;
 "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
(FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT)
@@ -1691,6 +1692,19 @@
(READTABLEP 8 (BITS . 7))
(READTABLEP 10 POINTER))
'12)
(DECLARE%: EVAL@COMPILE
(DATATYPE READER-ENVIRONMENT (REPACKAGE REREADTABLE REBASE REPACKAGEFORM REFORMAT REREADTABLEFORM))
)
(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER)
'((READER-ENVIRONMENT 0 POINTER)
(READER-ENVIRONMENT 2 POINTER)
(READER-ENVIRONMENT 4 POINTER)
(READER-ENVIRONMENT 6 POINTER)
(READER-ENVIRONMENT 8 POINTER)
(READER-ENVIRONMENT 10 POINTER))
'12)
(* "END EXPORTED DEFINITIONS")
@@ -1726,6 +1740,15 @@
(READTABLEP 10 POINTER))
'12)
(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER)
'((READER-ENVIRONMENT 0 POINTER)
(READER-ENVIRONMENT 2 POINTER)
(READER-ENVIRONMENT 4 POINTER)
(READER-ENVIRONMENT 6 POINTER)
(READER-ENVIRONMENT 8 POINTER)
(READER-ENVIRONMENT 10 POINTER))
'12)
(RPAQ? \READTABLEHASH )
(DEFINEQ
@@ -1813,15 +1836,6 @@
NIL])
)
(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER)
'((READER-ENVIRONMENT 0 POINTER)
(READER-ENVIRONMENT 2 POINTER)
(READER-ENVIRONMENT 4 POINTER)
(READER-ENVIRONMENT 6 POINTER)
(READER-ENVIRONMENT 8 POINTER)
(READER-ENVIRONMENT 10 POINTER))
'12)
(* ; "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
@@ -1922,22 +1936,22 @@
(ADDTOVAR LAMA READTABLEPROP)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (17619 28771 (GETSYNTAX 17629 . 22460) (SETSYNTAX 22462 . 23535) (SYNTAXP 23537 . 26034)
(\COPYSYNTAX 26036 . 26753) (\GETCHARCODE 26755 . 27043) (\SETFATSYNCODE 27045 . 28336) (
\MAPCHARTABLE 28338 . 28769)) (28804 43770 (CONTROL 28814 . 29066) (COPYTERMTABLE 29068 . 29435) (
DELETECONTROL 29437 . 32078) (GETDELETECONTROL 32080 . 33042) (ECHOCHAR 33044 . 34485) (ECHOCONTROL
34487 . 34944) (ECHOMODE 34946 . 35192) (GETECHOMODE 35194 . 35358) (GETCONTROL 35360 . 35526) (
GETTERMTABLE 35528 . 35595) (RAISE 35597 . 36023) (GETRAISE 36025 . 36187) (RESETTERMTABLE 36189 .
37273) (SETTERMTABLE 37275 . 37509) (TERMTABLEP 37511 . 37672) (\GETTERMSYNTAX 37674 . 37945) (
\GTTERMTABLE 37947 . 38283) (\ORIGTERMTABLE 38285 . 41895) (\SETTERMSYNTAX 41897 . 42532) (
\TERMCLASSTOCODE 42534 . 42963) (\TERMCODETOCLASS 42965 . 43352) (\LITCHECK 43354 . 43768)) (46281
70105 (COPYREADTABLE 46291 . 46489) (FIND-READTABLE 46491 . 46638) (IN-READTABLE 46640 . 46800) (
ESCAPE 46802 . 47055) (GETBRK 47057 . 47195) (GETREADTABLE 47197 . 47333) (GETSEPR 47335 . 47473) (
READMACROS 47475 . 47738) (READTABLEP 47740 . 47903) (READTABLEPROP 47905 . 53063) (RESETREADTABLE
53065 . 57312) (SETBRK 57314 . 58924) (SETREADTABLE 58926 . 59114) (SETSEPR 59116 . 60658) (
\GETREADSYNTAX 60660 . 63350) (\GTREADTABLE 63352 . 63577) (\GTREADTABLE1 63579 . 63835) (
\ORIGREADTABLE 63837 . 65745) (\READCLASSTOCODE 65747 . 66198) (\SETMACROSYNTAX 66200 . 67995) (
\SETREADSYNTAX 67997 . 69058) (\READTABLEP.DEFPRINT 69060 . 70103)) (82937 87494 (\ATBLSET 82947 .
87492)) (87941 91385 (MAKE-READER-ENVIRONMENT 87951 . 89608) (EQUAL-READER-ENVIRONMENT 89610 . 90787)
(SET-READER-ENVIRONMENT 90789 . 91383)))))
(FILEMAP (NIL (17652 28804 (GETSYNTAX 17662 . 22493) (SETSYNTAX 22495 . 23568) (SYNTAXP 23570 . 26067)
(\COPYSYNTAX 26069 . 26786) (\GETCHARCODE 26788 . 27076) (\SETFATSYNCODE 27078 . 28369) (
\MAPCHARTABLE 28371 . 28802)) (28837 43803 (CONTROL 28847 . 29099) (COPYTERMTABLE 29101 . 29468) (
DELETECONTROL 29470 . 32111) (GETDELETECONTROL 32113 . 33075) (ECHOCHAR 33077 . 34518) (ECHOCONTROL
34520 . 34977) (ECHOMODE 34979 . 35225) (GETECHOMODE 35227 . 35391) (GETCONTROL 35393 . 35559) (
GETTERMTABLE 35561 . 35628) (RAISE 35630 . 36056) (GETRAISE 36058 . 36220) (RESETTERMTABLE 36222 .
37306) (SETTERMTABLE 37308 . 37542) (TERMTABLEP 37544 . 37705) (\GETTERMSYNTAX 37707 . 37978) (
\GTTERMTABLE 37980 . 38316) (\ORIGTERMTABLE 38318 . 41928) (\SETTERMSYNTAX 41930 . 42565) (
\TERMCLASSTOCODE 42567 . 42996) (\TERMCODETOCLASS 42998 . 43385) (\LITCHECK 43387 . 43801)) (46314
70138 (COPYREADTABLE 46324 . 46522) (FIND-READTABLE 46524 . 46671) (IN-READTABLE 46673 . 46833) (
ESCAPE 46835 . 47088) (GETBRK 47090 . 47228) (GETREADTABLE 47230 . 47366) (GETSEPR 47368 . 47506) (
READMACROS 47508 . 47771) (READTABLEP 47773 . 47936) (READTABLEPROP 47938 . 53096) (RESETREADTABLE
53098 . 57345) (SETBRK 57347 . 58957) (SETREADTABLE 58959 . 59147) (SETSEPR 59149 . 60691) (
\GETREADSYNTAX 60693 . 63383) (\GTREADTABLE 63385 . 63610) (\GTREADTABLE1 63612 . 63868) (
\ORIGREADTABLE 63870 . 65778) (\READCLASSTOCODE 65780 . 66231) (\SETMACROSYNTAX 66233 . 68028) (
\SETREADSYNTAX 68030 . 69091) (\READTABLEP.DEFPRINT 69093 . 70136)) (83789 88346 (\ATBLSET 83799 .
88344)) (88449 91893 (MAKE-READER-ENVIRONMENT 88459 . 90116) (EQUAL-READER-ENVIRONMENT 90118 . 91295)
(SET-READER-ENVIRONMENT 91297 . 91891)))))
STOP

BIN
sources/ATBL.LCOM
View File

Binary file not shown.

336
sources/BOOTSTRAP
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "23-Apr-2025 23:39:10" {WMEDLEY}<sources>BOOTSTRAP.;61 47417
(FILECREATED "25-Feb-2026 15:03:24" {WMEDLEY}<sources>BOOTSTRAP.;69 47041
:EDIT-BY rmk
:CHANGES-TO (FNS PRINT-READER-ENVIRONMENT \DO-DEFINE-FILE-INFO)
:CHANGES-TO (FNS MAKE-DEFINE-FILE-INFO-ENV READ-READER-ENVIRONMENT)
:PREVIOUS-DATE "27-Sep-2021 10:25:31" {WMEDLEY}<sources>BOOTSTRAP.;59)
:PREVIOUS-DATE "25-Feb-2026 13:52:00" {WMEDLEY}<sources>BOOTSTRAP.;66)
(PRETTYCOMPRINT BOOTSTRAPCOMS)
@@ -365,15 +365,15 @@
(\LOAD-STREAM
[LAMBDA (STREAM LDFLG PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)
(DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM))
(* ; "Edited 17-Jul-2021 21:58 by rmk:")
(DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM)) (* ; "Edited 25-Feb-2026 13:46 by rmk")
(* ; "Edited 17-Jul-2021 21:58 by rmk:")
(* ;;; "Internal function that loads from an already open stream. LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such. Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.")
(* ;;; "Internal function that loads from an already open stream. LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such. Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.")
(PROG ((*STANDARD-INPUT* STREAM)
(FILE (FULLNAME STREAM))
(*PACKAGE* *PACKAGE*)
(*READTABLE* (PROG1 FILERDTBL (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read")
(*READTABLE* (PROG1 FILERDTBL (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read")
))
(DFNFLG DFNFLG)
(BUILDMAPFLG BUILDMAPFLG)
@@ -385,176 +385,168 @@
FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP INTERLISP-P
FILECREATEDLOC)
(DECLARE (SPECVARS DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FILECREATEDLST
DEFINEDENV FILECREATEDLOC FILE))
DEFINEDENV FILECREATEDLOC FILE))
(if (AND LOAD-VERBOSE-STREAM FILE)
then (LISPXTERPRI LOAD-VERBOSE-STREAM)
(if (NEQ LOAD-VERBOSE-STREAM T)
then (* ;
 "CL:LOAD says to prefix this stuff with comment marker")
(PRIN1 "; Loading " LOAD-VERBOSE-STREAM))
(* ;
 "Might use EXEC-FORMAT here except that it isn't defined early in loadup")
(LISPXPRIN1 FILE LOAD-VERBOSE-STREAM)
(LISPXTERPRI LOAD-VERBOSE-STREAM))
(if (NEQ LOAD-VERBOSE-STREAM T)
then (* ;
 "CL:LOAD says to prefix this stuff with comment marker")
(PRIN1 "; Loading " LOAD-VERBOSE-STREAM))
(* ;
 "Might use EXEC-FORMAT here except that it isn't defined early in loadup")
(LISPXPRIN1 FILE LOAD-VERBOSE-STREAM)
(LISPXTERPRI LOAD-VERBOSE-STREAM))
(if (EQ (SETQ DFNFLG LDFLG)
'SYSLOAD)
'SYSLOAD)
then (SETQ DFNFLG T)
(SETQ ADDSPELLFLG NIL)
(SETQ BUILDMAPFLG NIL)
(SETQ FILEPKGFLG NIL)
(SETQ LISPXHIST NIL))
(SETQ ADDSPELLFLG NIL)
(SETQ BUILDMAPFLG NIL)
(SETQ FILEPKGFLG NIL)
(SETQ LISPXHIST NIL))
(if LISPXHIST
then (* ;
 "Want UNDOSAVE to keep saving regardless of how many undosaves are involved")
(if (SETQ LOADA (FMEMB 'SIDE LISPXHIST))
then (FRPLACA (CADR LOADA)
-1)
else (LISPXPUT 'SIDE (LIST -1)
NIL LISPXHIST)))
then (* ;
 "Want UNDOSAVE to keep saving regardless of how many undosaves are involved")
(if (SETQ LOADA (FMEMB 'SIDE LISPXHIST))
then (FRPLACA (CADR LOADA)
-1)
else (LISPXPUT 'SIDE (LIST -1)
NIL LISPXHIST)))
(if (EQ (SETQ TEM (SKIPSEPRCODES STREAM))
FASL:SIGNATURE)
then (* ;
 "FASL file handled by FASL loader")
(FASL:PROCESS-FILE STREAM)
[LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T))
'FILEDATES]
(if (NOT (MEMB FILE LOADEDFILELST))
then (* ;
 "Keep track of every file loaded.")
(SETQ LOADEDFILELST (CONS FILE LOADEDFILELST)))
(if MANAGED-FILE-P
then (if (EQ LDFLG 'SYSLOAD)
then
FASL:SIGNATURE)
then (* ; "FASL file handled by FASL loader")
(FASL:PROCESS-FILE STREAM)
[LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T))
'FILEDATES]
(if (NOT (MEMB FILE LOADEDFILELST))
then (* ; "Keep track of every file loaded.")
(SETQ LOADEDFILELST (CONS FILE LOADEDFILELST)))
(if MANAGED-FILE-P
then (if (EQ LDFLG 'SYSLOAD)
then
(* ;;
 "Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag")
(* ;;
 "Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag")
(if (NOT (MEMB ROOTNAME SYSFILES))
then (SETQ SYSFILES (NCONC1 SYSFILES
ROOTNAME)))
(SMASHFILECOMS ROOTNAME)
elseif FILEPKGFLG
then (ADDFILE ROOTNAME 'Compiled]
(RETURN FILE)
(if (NOT (MEMB ROOTNAME SYSFILES))
then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
(SMASHFILECOMS ROOTNAME)
elseif FILEPKGFLG
then (ADDFILE ROOTNAME 'Compiled]
(RETURN FILE)
elseif (NEQ TEM (CHARCODE "("))
then (RETURN (\CML-LOAD STREAM PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)))
(if (AND BUILDMAPFLG (RANDACCESSP STREAM))
then (SETQ MAYBEWANTFILEMAP T))
(* ;; "Get the environment from the DEFINE-FILE-INFO expression. This is read in the DEFINE-FILE-INFO-ENVIRONMENT.")
(* ;; "Get the environment from the DEFINE-FILE-INFO expression. This is read in the DEFINE-FILE-INFO-ENVIRONMENT.")
(SETQ DEFINEDENV (READ-READER-ENVIRONMENT STREAM *OLD-INTERLISP-READ-ENVIRONMENT*))
(SETQ DEFINEDENV (READ-READER-ENVIRONMENT STREAM))
(CL:WHEN PACKAGE
(* ;; "Caller better really mean it--overrides what's on file! But we don't want to smash what the reader returned, couldbe the old-interlisp-file-env.")
(* ;; "Caller better really mean it--overrides what's on file! But we don't want to smash what the reader returned, couldbe the old-interlisp-file-env.")
[SETQ DEFINEDENV (CREATE READER-ENVIRONMENT USING DEFINEDENV REPACKAGE _
(SETQ *PACKAGE*
(\DTEST PACKAGE 'PACKAGE])
(SETQ *PACKAGE* (\DTEST PACKAGE
'PACKAGE])
(* ;; "At this point we have the environment for the file, the external format is set. We now read/interpret all the other forms.")
(* ;; "At this point we have the environment for the file, the external format is set. We now read/interpret all the other forms.")
(WITH-READER-ENVIRONMENT DEFINEDENV
(PROG (ADR)
LP (if FILEMAP
then (* ;
 "need to build map, so read carefully")
(SETQ LOADA (SKIPSEPRCODES STREAM))
(if (OR (SYNTAXP LOADA 'LEFTPAREN)
(SYNTAXP LOADA 'LEFTBRACKET))
then (* ; "See if we have a DEFINEQ")
(SETQ ADR (GETFILEPTR STREAM))
(READCCODE STREAM) (* ; "Eat paren")
(if (EQ (RATOM STREAM)
'DEFINEQ)
then (SETQ FNADRLST (TCONC NIL ADR))
(TCONC FNADRLST NIL)
(TCONC FILEMAP (CAR FNADRLST))
(GO DEFQLP))
(* ; "Not a DEFINEQ, so back out")
(SETFILEPTR STREAM ADR)))
then (* ;
 "need to build map, so read carefully")
(SETQ LOADA (SKIPSEPRCODES STREAM))
(if (OR (SYNTAXP LOADA 'LEFTPAREN)
(SYNTAXP LOADA 'LEFTBRACKET))
then (* ; "See if we have a DEFINEQ")
(SETQ ADR (GETFILEPTR STREAM))
(READCCODE STREAM) (* ; "Eat paren")
(if (EQ (RATOM STREAM)
'DEFINEQ)
then (SETQ FNADRLST (TCONC NIL ADR))
(TCONC FNADRLST NIL)
(TCONC FILEMAP (CAR FNADRLST))
(GO DEFQLP)) (* ; "Not a DEFINEQ, so back out")
(SETFILEPTR STREAM ADR)))
(SELECTQ (SETQ LOADA (READ STREAM))
((STOP NIL)
(if (EQ LDFLG 'SYSLOAD)
then (if (NOT (MEMB (SETQ ROOTNAME
(ROOTFILENAME FILE
(CDR FILECREATEDLST)))
SYSFILES))
then (SETQ SYSFILES (NCONC1 SYSFILES
ROOTNAME)))
(SMASHFILECOMS ROOTNAME)
elseif FILEPKGFLG
then
((STOP NIL)
(if (EQ LDFLG 'SYSLOAD)
then (if (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR
FILECREATEDLST
)))
SYSFILES))
then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
(SMASHFILECOMS ROOTNAME)
elseif FILEPKGFLG
then
(* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES. Also, we want items mentioned earlier to be deleted if they are taken care of by this file. The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.")
(* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES. Also, we want items mentioned earlier to be deleted if they are taken care of by this file. The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.")
(ADDFILE FILE T PRLST FILECREATEDLST))
[if FILEMAP
then (PUTFILEMAP FILE (CAR FILEMAP)
FILECREATEDLST DEFINEDENV NIL FILECREATEDLOC)
(if UPDATEMAPFLG
then (SETFILEPTR STREAM ADR)
(* ;
 "address of last expression read. good hint for finding filemap")
(UPDATEFILEMAP STREAM (CAR FILEMAP]
(if (NOT (MEMB FILE LOADEDFILELST))
then (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST)))
(RETURN))
NIL)
(ADDFILE FILE T PRLST FILECREATEDLST))
[if FILEMAP
then (PUTFILEMAP FILE (CAR FILEMAP)
FILECREATEDLST DEFINEDENV NIL FILECREATEDLOC)
(if UPDATEMAPFLG
then (SETFILEPTR STREAM ADR)
(* ;
 "address of last expression read. good hint for finding filemap")
(UPDATEFILEMAP STREAM (CAR FILEMAP]
(if (NOT (MEMB FILE LOADEDFILELST))
then (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST)))
(RETURN))
NIL)
[if (LISTP LOADA)
then
(SELECTQ (CAR LOADA)
(FILECREATED (if MAYBEWANTFILEMAP
then (* ; "See if we have a valid file map")
(SETQ ADR (GETFILEPTR STREAM))
(if [AND (FIXP (SETQ TEM (CADDDR LOADA)))
[SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM
TEM)
(READ STREAM]
(EQ (CAR TEM)
'FILEMAP)
(NULL (CAR (SETQ TEM (CADR TEM]
then (* ; "Has ok map")
(PUTFILEMAP FILE TEM NIL DEFINEDENV)
else (* ;
 "Need to build a file map as we go")
(SETQ FILEMAP (TCONC NIL NIL)))
(SETFILEPTR STREAM ADR)
(SETQ MAYBEWANTFILEMAP NIL))
(SETQ LOADA (\EVAL LOADA)))
(SETQ LOADA (\EVAL LOADA)))
else (* ;
 "Atom found. Compiled code definition.")
(if ADDSPELLFLG
then (ADDSPELL LOADA))
(if FILEMAP
then (SETQ ADR (GETFILEPTR STREAM)))
(LAPRD LOADA)
(if FILEMAP
then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM)
LOADA]
(FILECREATED (if MAYBEWANTFILEMAP
then (* ; "See if we have a valid file map")
(SETQ ADR (GETFILEPTR STREAM))
(if [AND (FIXP (SETQ TEM (CADDDR LOADA)))
[SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM
TEM)
(READ STREAM]
(EQ (CAR TEM)
'FILEMAP)
(NULL (CAR (SETQ TEM (CADR TEM]
then (* ; "Has ok map")
(PUTFILEMAP FILE TEM NIL DEFINEDENV)
else (* ; "Need to build a file map as we go")
(SETQ FILEMAP (TCONC NIL NIL)))
(SETFILEPTR STREAM ADR)
(SETQ MAYBEWANTFILEMAP NIL))
(SETQ LOADA (\EVAL LOADA)))
(SETQ LOADA (\EVAL LOADA)))
else (* ;
 "Atom found. Compiled code definition.")
(if ADDSPELLFLG
then (ADDSPELL LOADA))
(if FILEMAP
then (SETQ ADR (GETFILEPTR STREAM)))
(LAPRD LOADA)
(if FILEMAP
then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM)
LOADA]
LP1 (if PRINTFLG
then (PRINT LOADA PRINTFLG))
(GO LP)
DEFQLP
(SELCHARQ (SKIPSEPRCODES STREAM)
((%) %]) (* ; "Closes DEFINEQ.")
((%) %]) (* ; "Closes DEFINEQ.")
(READCCODE STREAM)
(if FNADRLST
then (RPLACA (CDAR FNADRLST)
(GETFILEPTR STREAM)))
(* ;
 "FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.")
(GETFILEPTR STREAM)))
(* ;
 "FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.")
(SETQ LOADA (DEFINE (DREVERSE LOADA)))
(GO LP1))
((%( %[) (* ;
 "another function/definition pair")
((%( %[) (* ; "another function/definition pair")
(SETQ ADR (GETFILEPTR STREAM))
(SETQ LOADA (CONS (READ STREAM)
LOADA))
[if FNADRLST
then (TCONC FNADRLST (CONS (CAAR LOADA)
(CONS ADR (GETFILEPTR STREAM]
(CONS ADR (GETFILEPTR STREAM]
(GO DEFQLP))
NIL)
(ERROR "illegal argument in defineq")))
@@ -808,20 +800,22 @@
(TERPRI STREAM)))])
(READ-READER-ENVIRONMENT
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 26-Sep-2021 23:31 by rmk:")
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 25-Feb-2026 14:15 by rmk")
(* ; "Edited 26-Sep-2021 23:31 by rmk:")
(* ;; "Starting environment is the old interlisp file, just for the seprchar scans.")
(* ;; "On exit, if the stream begins with a DEFINE-FILE-INFO expression, it is positioned just after that expression. If not, it is left at its starting position. ")
(* ;; "RETURNFORM=T means return the DEFINE-FILE-INFO as a second value, for READFILE")
(CL:UNLESS DEFAULTENV (SETQ DEFAULTENV *OLD-INTERLISP-READ-ENVIRONMENT*))
(LET ((START (GETFILEPTR STREAM))
ARGS
(ENV DEFAULTENV)
(*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF
*OLD-INTERLISP-READ-ENVIRONMENT*
)))
(*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF *OLD-INTERLISP-READ-ENVIRONMENT*)))
(DECLARE (SPECVARS *READTABLE*))
(SETFILEPTR STREAM 0) (* ; "Hope we are RANDACCESSP")
(SELCHARQ (SKIPSEPRCODES STREAM)
(";" (* ; "Assume it's a common lisp file")
(\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
@@ -831,24 +825,21 @@
("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
*DEFINE-FILE-INFO-ENV*
)) (* ;
 "Should we reset the format if we fail?")
 "Should we reset the format if we fail?")
(READCCODE STREAM)
(WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV*
(IF (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM))
THEN
(if (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM))
then
(* ;;
 "After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.")
(* ;;
 "After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.")
[SETQ ENV (\DO-DEFINE-FILE-INFO STREAM (SETQ ARGS
(CL:READ-DELIMITED-LIST
(CHARCODE ")")
STREAM]
ELSE (* ; "Hope we are RANDACCESSP")
(SETFILEPTR STREAM START))
(SETQ ARGS (CL:READ-DELIMITED-LIST (CHARCODE ")")
STREAM))
(SETQ ENV (\DO-DEFINE-FILE-INFO STREAM ARGS))
else (SETFILEPTR STREAM START))
(* ;;
 "If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.")
 "If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.")
(CL:IF (AND RETURNFORM ARGS)
(CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS))
@@ -856,25 +847,26 @@
DEFAULTENV])
(MAKE-DEFINE-FILE-INFO-ENV
[LAMBDA NIL (* ; "Edited 29-Jul-2021 20:29 by rmk:")
[LAMBDA NIL (* ; "Edited 25-Feb-2026 15:03 by rmk")
(* ; "Edited 29-Jul-2021 20:29 by rmk:")
(* ;; "Makes the reader environment and read table used for printing and reading the DEFINE-FILE-INFO expression. Like the OLD-INTERLISP-FILE, but : is the preferred package delim")
(* ;; "Makes the reader environment and read table used for printing and reading the DEFINE-FILE-INFO expression. Like the OLD-INTERLISP-FILE, but : is the preferred package delim")
(LET [(RTBL (COPYREADTABLE (FETCH REREADTABLE OF *OLD-INTERLISP-READ-ENVIRONMENT*]
(* ;;
 "But this is all rather silly: Why not just have ordinary Interlisp atoms for the key words. ")
(* (READTABLEPROP RTBL
 (QUOTE PACKAGECHAR)
 (CHARCODE %:)))
(* ;;
 "But this is all rather silly: Why not just have ordinary Interlisp atoms for the key words. ")
(* (READTABLEPROP RTBL
 (QUOTE PACKAGECHAR) (CHARCODE %:)))
(SETSYNTAX (CHARCODE %:)
'PACKAGEDELIM RTBL) (* ;
 "In transition: read : but don't yet put it out")
'PACKAGEDELIM RTBL)
(replace (READTABLEP PACKAGECHAR) of RTBL with (CHARCODE %:))
(* ;
 "Use : instead of ^^ for printing too")
(* ;; "The INTERLISP package doesn't exist in bootstrap, the REPACKAGE field is filled in in PACKAGE-ENABLE in PACKAGE-STARTUP")
(* ;; "The INTERLISP package doesn't exist in bootstrap, the REPACKAGE field is filled in in PACKAGE-ENABLE in PACKAGE-STARTUP")
(CREATE READER-ENVIRONMENT USING *OLD-INTERLISP-READ-ENVIRONMENT* REREADTABLE _ RTBL
])
(CREATE READER-ENVIRONMENT USING *OLD-INTERLISP-READ-ENVIRONMENT* REREADTABLE _ RTBL])
)
(RPAQ? *DEFINE-FILE-INFO-ENV* (MAKE-DEFINE-FILE-INFO-ENV))
@@ -977,13 +969,13 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4617 14289 (GETPROP 4627 . 5199) (SETATOMVAL 5201 . 5330) (RPAQQ 5332 . 5385) (RPAQ
5387 . 5699) (RPAQ? 5701 . 6071) (MOVD 6073 . 7937) (MOVD? 7939 . 8369) (SELECTQ 8371 . 8558) (
SELECTQ1 8560 . 8902) (NCONC1 8904 . 9100) (PUTPROP 9102 . 10586) (PROPNAMES 10588 . 10779) (ADDPROP
10781 . 12844) (REMPROP 12846 . 13700) (MEMB 13702 . 13961) (CLOSEF? 13963 . 14287)) (14362 34926 (
LOAD 14372 . 15541) (\LOAD-STREAM 15543 . 28617) (FILECREATED 28619 . 30037) (FILECREATED1 30039 .
31147) (PRETTYCOMPRINT 31149 . 31634) (BOOTSTRAP-NAMEFIELD 31636 . 32596) (PUTPROPS 32598 . 32966) (
DECLARE%: 32968 . 33100) (DECLARE%:1 33102 . 33974) (ROOTFILENAME 33976 . 34924)) (34964 45363 (
DEFINE-FILE-INFO 34974 . 35409) (\DO-DEFINE-FILE-INFO 35411 . 39554) (PRINT-READER-ENVIRONMENT 39556
. 41308) (READ-READER-ENVIRONMENT 41310 . 44085) (MAKE-DEFINE-FILE-INFO-ENV 44087 . 45361)))))
(FILEMAP (NIL (4621 14293 (GETPROP 4631 . 5203) (SETATOMVAL 5205 . 5334) (RPAQQ 5336 . 5389) (RPAQ
5391 . 5703) (RPAQ? 5705 . 6075) (MOVD 6077 . 7941) (MOVD? 7943 . 8373) (SELECTQ 8375 . 8562) (
SELECTQ1 8564 . 8906) (NCONC1 8908 . 9104) (PUTPROP 9106 . 10590) (PROPNAMES 10592 . 10783) (ADDPROP
10785 . 12848) (REMPROP 12850 . 13704) (MEMB 13706 . 13965) (CLOSEF? 13967 . 14291)) (14366 34343 (
LOAD 14376 . 15545) (\LOAD-STREAM 15547 . 28034) (FILECREATED 28036 . 29454) (FILECREATED1 29456 .
30564) (PRETTYCOMPRINT 30566 . 31051) (BOOTSTRAP-NAMEFIELD 31053 . 32013) (PUTPROPS 32015 . 32383) (
DECLARE%: 32385 . 32517) (DECLARE%:1 32519 . 33391) (ROOTFILENAME 33393 . 34341)) (34381 44987 (
DEFINE-FILE-INFO 34391 . 34826) (\DO-DEFINE-FILE-INFO 34828 . 38971) (PRINT-READER-ENVIRONMENT 38973
. 40725) (READ-READER-ENVIRONMENT 40727 . 43553) (MAKE-DEFINE-FILE-INFO-ENV 43555 . 44985)))))
STOP

BIN
sources/BOOTSTRAP.LCOM
View File

Binary file not shown.

270
sources/CLISP
View File

@@ -1,18 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "16-May-90 12:27:02" {DSK}<usr>local>lde>lispcore>sources>CLISP.;2 45083
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
changes to%: (VARS CLISPCOMS)
(FILECREATED "19-Feb-2026 12:00:55" {WMEDLEY}<sources>CLISP.;2 44501
previous date%: "26-Nov-86 12:32:58" {DSK}<usr>local>lde>lispcore>sources>CLISP.;1)
:EDIT-BY rmk
:PREVIOUS-DATE "16-May-90 12:27:02" {WMEDLEY}<sources>CLISP.;1)
(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")
(PRETTYCOMPRINT CLISPCOMS)
@@ -57,16 +50,16 @@ with the terms of said license.
(COMS (* CLISP props)
(PROP CLISPTYPE %')
[E (SETQQ CLISPCHARS
(^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­))
(↑ * / + - = ← %: %' ~ +- ~= < > @ ! _ ^))
(CLISPDEC '(STANDARD MIXED]
[VARS (CLISPFLG T)
(CLISPCHARS '(^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­]
(CLISPCHARS '(↑ * / + - = ← %: %' ~ +- ~= < > @ ! _ ^]
(INITVARS (CLISPHELPFLG T)
(TREATASCLISPFLG)
(CLISPINFIXSPLST)
(CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
[LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(_ ¬]
(LEFT.ARROW '_)
[LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(← _]
(LEFT.ARROW '←)
(CLISPISWORDSPLST)
(CLISPLASTSUB (CONS))
(CHECKCARATOMFLG)
@@ -74,7 +67,7 @@ with the terms of said license.
(CLISPARITHCLASSLST '(INTEGER FIXED MIXED FLOATING))
(DWIMINMACROSFLG NIL))
(IFPROP (CLISPTYPE LISPFN UNARYOP CLISPCLASS CLISPCLASSDEF CLISPNEG CLISPBRACKET)
­ ^ * / + - = _ ¬ %: %' ~ +- ~= < > @ !)
^ ↑ * / + - = ← _ %: %' ~ +- ~= < > @ !)
(VARS DECLWORDS)
(IFPROP (CLISPTYPE LISPFN UNARYOP CLISPINFIX CLISPCLASS CLISPCLASSDEF CLISPNEG
BROADSCOPE)
@@ -160,34 +153,14 @@ with the terms of said license.
(RPAQ? RPARKEY 0)
(RPAQ? WTFIXCHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL))
(RPAQ? WTFIXCHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL))
(RPAQ? WTFIXCHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL))
(RPAQ? WTFIXCHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL))
(ADDTOVAR EDITMACROS
(FIX9 (X N)
(BIND (E (SETQ %#1 (EDITFPAT 'X))
T)
(IF (NOT (ATOM (%##)))
(1))
(COMS (SPLIT89 RPARKEY N))
(I F RPARKEY T)
(E [SETQ %#2 (ADD1 (LENGTH (CAR L]
T)
!0 MARK (LPQ [IF (OR (NULL %#1)
(NOT (EDIT4E %#1 (%## 1]
UP
(E (SETQ %#3 (LENGTH (CAR L)))
T)
(I RI 1 (MINUS %#2))
(E (SETQ %#2 %#3)
T)
1 !0)
__
(DELETE NX)))
(FIX9 NIL (FIX9))
(FIX8 NIL (FIX8))
(FIX8 (X N)
(BIND (E (SETQ %#1 (EDITFPAT 'X))
T)
@@ -206,14 +179,34 @@ with the terms of said license.
UP
(RO 1)
!0)))
(FIX8 NIL (FIX8)))
(FIX9 NIL (FIX9))
(FIX9 (X N)
(BIND (E (SETQ %#1 (EDITFPAT 'X))
T)
(IF (NOT (ATOM (%##)))
(1))
(COMS (SPLIT89 RPARKEY N))
(I F RPARKEY T)
(E [SETQ %#2 (ADD1 (LENGTH (CAR L]
T)
!0 MARK (LPQ [IF (OR (NULL %#1)
(NOT (EDIT4E %#1 (%## 1]
UP
(E (SETQ %#3 (LENGTH (CAR L)))
T)
(I RI 1 (MINUS %#2))
(E (SETQ %#2 %#3)
T)
1 !0)
←←
(DELETE NX))))
(ADDTOVAR DWIMUSERFORMS )
(ADDTOVAR LAMBDASPLST LAMBDA NLAMBDA)
(ADDTOVAR OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1
APPEND NEQ NOT NULL)
(ADDTOVAR OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1 APPEND
NEQ NOT NULL)
(ADDTOVAR NOFIXFNSLST )
@@ -266,6 +259,17 @@ with the terms of said license.
(ADDTOVAR DWIMEQUIVLST )
(ADDTOVAR EDITMACROS
(CLISP%: NIL (BIND (E (COND ((SETQ %#1 (AND CLISPARRAY (GETHASH (%##)
CLISPARRAY)))
(SETQQ COM CLISP%:)
(EDITE %#1))
(T (PRIN1 '"not translated.
" T)))
T)))
(NOCLISP COMS (RESETVAR CLISPTRANFLG NIL . COMS))
(NOCLISP NIL (NOCLISP TTY%:))
(!DW NIL (RESETVAR CLISPRETRANFLG T DW))
(PPT NIL (RESETVAR PRETTYTRANFLG T PP))
(DW NIL (BIND (E (PROGN (SETQ %#1 (%##))
(AND (CDR L)
(%## !0 (E (SETQ %#2 L)
@@ -280,18 +284,7 @@ with the terms of said license.
(IF (LISTP %#3)
(1)
NIL))
NIL)))
(PPT NIL (RESETVAR PRETTYTRANFLG T PP))
(!DW NIL (RESETVAR CLISPRETRANFLG T DW))
(NOCLISP NIL (NOCLISP TTY%:))
(NOCLISP COMS (RESETVAR CLISPTRANFLG NIL . COMS))
(CLISP%: NIL (BIND (E (COND ((SETQ %#1 (AND CLISPARRAY (GETHASH (%##)
CLISPARRAY)))
(SETQQ COM CLISP%:)
(EDITE %#1))
(T (PRIN1 '"not translated.
" T)))
T))))
NIL))))
(ADDTOVAR EDITCOMSA PPT DW !DW CLISP%:)
@@ -304,7 +297,7 @@ with the terms of said license.
(RPAQQ CLISPFLG T)
(RPAQQ CLISPCHARS (^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­))
(RPAQQ CLISPCHARS (↑ * / + - = ← %: %' ~ +- ~= < > @ ! _ ^))
(RPAQ? CLISPHELPFLG T)
@@ -314,9 +307,9 @@ with the terms of said license.
(RPAQ? CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
(RPAQ? LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(_ ¬)))
(RPAQ? LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(← _)))
(RPAQ? LEFT.ARROW '_)
(RPAQ? LEFT.ARROW '←)
(RPAQ? CLISPISWORDSPLST )
@@ -330,10 +323,10 @@ with the terms of said license.
(RPAQ? DWIMINMACROSFLG NIL)
(PUTPROPS ­ CLISPTYPE 6)
(PUTPROPS ^ CLISPTYPE 6)
(PUTPROPS ↑ CLISPTYPE 6)
(PUTPROPS * CLISPTYPE 4)
(PUTPROPS / CLISPTYPE 4)
@@ -344,9 +337,9 @@ with the terms of said license.
(PUTPROPS = CLISPTYPE -20)
(PUTPROPS _ CLISPTYPE (8 . -12))
(PUTPROPS ← CLISPTYPE (8 . -12))
(PUTPROPS ¬ CLISPTYPE (8 . -12))
(PUTPROPS _ CLISPTYPE (8 . -12))
(PUTPROPS %: CLISPTYPE (14 . 13))
@@ -360,10 +353,10 @@ with the terms of said license.
(PUTPROPS > CLISPTYPE BRACKET)
(PUTPROPS ­ LISPFN EXPT)
(PUTPROPS ^ LISPFN EXPT)
(PUTPROPS ↑ LISPFN EXPT)
(PUTPROPS * LISPFN TIMES)
(PUTPROPS / LISPFN QUOTIENT)
@@ -374,9 +367,9 @@ with the terms of said license.
(PUTPROPS = LISPFN EQ)
(PUTPROPS _ LISPFN SETQ)
(PUTPROPS ← LISPFN SETQ)
(PUTPROPS ¬ LISPFN SETQ)
(PUTPROPS _ LISPFN SETQ)
(PUTPROPS %' LISPFN QUOTE)
@@ -750,7 +743,7 @@ with the terms of said license.
(PUTPROPS OR CLISPINFIX or)
(PUTPROPS SETQ CLISPINFIX _)
(PUTPROPS SETQ CLISPINFIX ←)
(PUTPROPS IPLUS CLISPINFIX +)
@@ -780,7 +773,7 @@ with the terms of said license.
(PUTPROPS GREATERP CLISPINFIX gt)
(PUTPROPS EXPT CLISPINFIX ^)
(PUTPROPS EXPT CLISPINFIX ↑)
(PUTPROPS LT CLISPCLASS LT)
@@ -931,7 +924,7 @@ with the terms of said license.
(PUTPROPS SETA SETFN (ELT))
(DEFOPTIMIZER CLISP%  (X &REST Y)
X)
X)
(PUTPROPS AND CLISPWORD T)
@@ -1146,83 +1139,82 @@ with the terms of said license.
(PUTPROPS while CLISPWORD (FORWORD . while))
(PUTPROPS always I.S.OPR ((COND ((NULL BODY)
(SETQ $$VAL NIL)
(GO $$OUT)))
BIND
(SETQ $$VAL T)))
(SETQ $$VAL NIL)
(GO $$OUT)))
BIND
(SETQ $$VAL T)))
(PUTPROPS collect I.S.OPR ((SETQ $$VAL (NCONC1 $$VAL BODY))))
(PUTPROPS count I.S.OPR ((AND BODY (SETQ $$VAL (ADD1 $$VAL)))
BIND
($$VAL _ 0)))
BIND
($$VAL ← 0)))
(PUTPROPS do I.S.OPR (BODY))
(PUTPROPS fcollect I.S.OPR [(= SUBPAIR '(VAR1 VAR2)
(LIST (GETDUMMYVAR T)
(GETDUMMYVAR T))
'(PROGN (SETQ VAR1 BODY)
(COND [VAR2 (FRPLACD VAR2 (SETQ VAR2 (LIST VAR1]
(T (SETQ $$VAL (SETQ VAR2 (LIST VAR1])
(LIST (GETDUMMYVAR T)
(GETDUMMYVAR T))
'(PROGN (SETQ VAR1 BODY)
(COND [VAR2 (FRPLACD VAR2 (SETQ VAR2 (LIST VAR1]
(T (SETQ $$VAL (SETQ VAR2 (LIST VAR1])
(PUTPROPS inside I.S.OPR [NIL = SUBST (GETDUMMYVAR)
'VAR
'(bind (VAR _ BODY)
eachtime
(COND ((NULL VAR)
(GO $$OUT))
((NLISTP VAR)
(SETQ I.V. VAR)
(SETQ VAR NIL))
(T (SETQ I.V. (CAR VAR))
(SETQ VAR (CDR VAR])
'VAR
'(bind (VAR ← BODY)
eachtime
(COND ((NULL VAR)
(GO $$OUT))
((NLISTP VAR)
(SETQ I.V. VAR)
(SETQ VAR NIL))
(T (SETQ I.V. (CAR VAR))
(SETQ VAR (CDR VAR])
(PUTPROPS join I.S.OPR ((SETQ $$VAL (NCONC $$VAL BODY))))
(PUTPROPS largest I.S.OPR [NIL = SUBST (GETDUMMYVAR)
'$$TEMP
'(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY)
(COND ((OR (NULL $$EXTREME)
(GREATERP $$TEMP $$EXTREME))
(SETQ $$EXTREME $$TEMP)
(SETQ $$VAL I.V.])
'$$TEMP
'(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY)
(COND ((OR (NULL $$EXTREME)
(GREATERP $$TEMP $$EXTREME))
(SETQ $$EXTREME $$TEMP)
(SETQ $$VAL I.V.])
(PUTPROPS never I.S.OPR ((COND (BODY (SETQ $$VAL NIL)
(GO $$OUT)))
BIND
($$VAL _ T)))
(GO $$OUT)))
BIND
($$VAL ← T)))
(PUTPROPS old I.S.OPR MODIFIER)
(PUTPROPS smallest I.S.OPR [NIL = SUBST (GETDUMMYVAR)
'$$TEMP
'(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY)
(COND ((OR (NULL $$EXTREME)
(LESSP $$TEMP $$EXTREME))
(SETQ $$EXTREME $$TEMP)
(SETQ $$VAL I.V.])
'$$TEMP
'(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY)
(COND ((OR (NULL $$EXTREME)
(LESSP $$TEMP $$EXTREME))
(SETQ $$EXTREME $$TEMP)
(SETQ $$VAL I.V.])
(PUTPROPS sum I.S.OPR ((SETQ $$VAL (PLUS $$VAL BODY))
BIND
($$VAL _ 0)))
BIND
($$VAL ← 0)))
(PUTPROPS thereis I.S.OPR [(COND (BODY (SETQ $$VAL (OR I.V. T))
(GO $$OUT])
(GO $$OUT])
(ADDTOVAR I.S.OPRLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT
FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD
ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU
TO UNLESS UNTIL WHEN WHERE WHILE always as bind by collect count
declare declare%: do eachtime fcollect finally find first for from in
inside isthere join largest never old on original repeatuntil
repeatwhile smallest suchthat sum thereis thru to unless until when
where while)
(ADDTOVAR I.S.OPRLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT FINALLY
FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD ON ORIGINAL
REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL
WHEN WHERE WHILE always as bind by collect count declare declare%: do
eachtime fcollect finally find first for from in inside isthere join
largest never old on original repeatuntil repeatwhile smallest suchthat
sum thereis thru to unless until when where while)
(ADDTOVAR CLISPFORWORDSPLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME
FCOLLECT FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN
LARGEST NEVER OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST
SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE)
(ADDTOVAR CLISPFORWORDSPLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT
FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER
OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM
THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE)
(RPAQQ CLISPDUMMYFORVARS ($$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6))
@@ -1241,17 +1233,18 @@ with the terms of said license.
(DEFINEQ
(DUMPI.S.OPRS
[NLAMBDA X (* lmm "14-Aug-84 18:34")
(* Dump I.S.OPRS definitions. -
redefined to dump out same case as given)
[NLAMBDA X (* lmm "14-Aug-84 18:34")
(* Dump I.S.OPRS definitions.
 -
 redefined to dump out same case as
 given)
(for Y in X collect (OR (GETDEF.I.S.OPR Y)
(PROG1 NIL (LISPXPRINT (LIST 'I.S.OPR Y 'not 'defined)
T T])
(PROG1 NIL
(LISPXPRINT (LIST 'I.S.OPR Y 'not 'defined)
T T))])
(GETDEF.I.S.OPR
[LAMBDA (Y) (* lmm "14-Aug-84 18:34")
[LAMBDA (Y) (* lmm "14-Aug-84 18:34")
(PROG (TEM BODY EVALFLG)
(RETURN
(CONS 'I.S.OPR
@@ -1279,9 +1272,9 @@ with the terms of said license.
[(CDR BODY)
(COND
(EVALFLG (SHOULDNT)))
(* somehow there was an = in front of the i.s.type and not in front of the
others. this shouldnt happen)
(* somehow there was an = in front of the i.s.type and not in front of the
 others. this shouldnt happen)
(LIST (KWOTE (CDR BODY]
(EVALFLG '(NIL T]
@@ -1298,11 +1291,11 @@ with the terms of said license.
(ADDTOVAR DURATIONCLISPWORDS (TIMERUNITS timerUnits timerunits)
(USINGBOX usingBox usingbox)
(USINGTIMER usingTimer usingtimer)
(FORDURATION forDuration forduration DURING during)
(RESOURCENAME resourceName resourcename)
(UNTILDATE untilDate untildate))
(USINGBOX usingBox usingbox)
(USINGTIMER usingTimer usingtimer)
(FORDURATION forDuration forduration DURING during)
(RESOURCENAME resourceName resourcename)
(UNTILDATE untilDate untildate))
(PUTPROPS TIMERUNITS CLISPWORD (FORWORD . timerUnits))
@@ -1477,7 +1470,6 @@ with the terms of said license.
(ADDTOVAR LAMA )
)
(PUTPROPS CLISP COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (37614 40224 (DUMPI.S.OPRS 37624 . 38032) (GETDEF.I.S.OPR 38034 . 40222)))))
(FILEMAP (NIL (36881 39751 (DUMPI.S.OPRS 36891 . 37559) (GETDEF.I.S.OPR 37561 . 39749)))))
STOP

BIN
sources/CLISP.DFASL Normal file
View File

Binary file not shown.

3
sources/CLISP.LCOM
View File

File diff suppressed because one or more lines are too long

136
sources/CMLCOMPILE
View File

@@ -1,18 +1,14 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "24-Sep-2023 14:11:25" {WMEDLEY}<sources>CMLCOMPILE.;2 22597
(FILECREATED "25-Feb-2026 23:03:38" {WMEDLEY}<sources>CMLCOMPILE.;4 25235
:EDIT-BY rmk
:CHANGES-TO (FNS COMPILE-IN-CORE)
:CHANGES-TO (FNS FAKE-COMPILE-FILE)
:PREVIOUS-DATE " 2-Jul-90 20:24:02" {WMEDLEY}<sources>CMLCOMPILE.;1)
:PREVIOUS-DATE "25-Feb-2026 19:50:29" {WMEDLEY}<sources>CMLCOMPILE.;3)
(* ; "
Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT CMLCOMPILECOMS)
(RPAQQ CMLCOMPILECOMS
@@ -46,8 +42,111 @@ Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation.
(DEFINEQ
(FAKE-COMPILE-FILE
(CL:LAMBDA (FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T) (COMPILER-OUTPUT T) (PROCESS-ENTIRE-FILE NIL PEFP)) (* ; "Edited 29-Jun-90 19:19 by nm") (LET (COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML) (NLAMA NLAMA) (LAMS LAMS) (LAMA LAMA) (DFNFLG NIL)) (DECLARE (CL:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG)) (RESETLST (RESETSAVE NIL (LIST (QUOTE RESETUNDO)) (RESETUNDO)) (RESETSAVE COUTFILE COMPILER-OUTPUT) (RESETSAVE STRF REDEFINE) (RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE (QUOTE DEFER))) (RESETSAVE LAPFLG LAP) (LET ((*PACKAGE* *INTERLISP-PACKAGE*) (*READ-BASE* 10) (LOCALVARS SYSLOCALVARS) (SPECVARS T) STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM) (DECLARE (CL:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL)) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ STREAM (OPENSTREAM FILENAME (QUOTE INPUT))))) (CL:MULTIPLE-VALUE-SETQ (ENV FORM) (\PARSE-FILE-HEADER STREAM (QUOTE RETURN) T)) (SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*))) (if (NOT PEFP) then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT)) (if LAP then (SETQ LSTFIL COUTFILE)) (SETQ FILENAME (FULLNAME STREAM)) (RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET) (SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) COMPILE.EXT (QUOTE BODY) FILENAME)) (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE BINARY))))) STREAM (ROOTFILENAME FILENAME))) (if OUTPUT-FILE then (RESETSAVE LCFIL OUTPUT-FILE) (PRINT-COMPILE-HEADER (LIST STREAM) (QUOTE ("COMPILE-FILEd")) ENV)) (WITH-READER-ENVIRONMENT ENV (PROG ((DEFERRED.EXPRESSIONS NIL) (*PRINT-ARRAY* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (FIRSTFORMS NIL) (AFTERS NIL) (SCRATCH.LCOM (QUOTE {CORE}SCRATCH.LCOM)) DUMMYFILE TEMPVAL) (DECLARE (CL:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL* *PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS)) (* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)") (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM (QUOTE BOTH) (QUOTE NEW))))) LPDUMP (if (EQUAL (CAR FORM) (QUOTE RPAQQ)) then (* ; "This is the support method of %"COMPILERVARS%" (2-July-1990 TT)") (SETQ TEMPVAL (CADDR FORM)) (if (SETQ TEMPVAL (ASSOC (QUOTE DECLARE%:) TEMPVAL)) then (if (SETQ TEMPVAL (FMEMB (QUOTE COMPILERVARS) (FMEMB (QUOTE DOEVAL@COMPILE) TEMPVAL))) then (SETQ DFNFLG T) (if (SETQ TEMPVAL (FMEMB (QUOTE ADDVARS) (SETQ TEMPVAL (CADR TEMPVAL)))) then (CL:DOLIST (ARG (CDR TEMPVAL)) (APPLY (QUOTE ADDTOVAR) ARG)))))) (COMPILE-FILE-EXPRESSION FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE) (SKIPSEPRCODES STREAM) (if (EOFP STREAM) then (CLOSEF STREAM) (for FORM in FIRSTFORMS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE T)) (COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE)) (CLOSEF? DUMMYFILE) (DELFILE (FULLNAME DUMMYFILE)) (AND PROCESS-ENTIRE-FILE (for EXP in (REVERSE DEFERRED.EXPRESSIONS) do (APPLY* (CAR EXP) (CDR EXP) OUTPUT-FILE))) (for FORM in AFTERS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE T)) (RETURN)) (SETQ FORM (READ STREAM)) (GO LPDUMP)) (PRINT NIL OUTPUT-FILE)) (SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE)))) (* ; "Do these after UNDONLSETQ entered") (MAPC (REVERSE COMPILE.FILE.AFTER) (FUNCTION EVAL)) COMPILE.FILE.VALUE))
)
(CL:LAMBDA
(FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T)
(COMPILER-OUTPUT T)
(PROCESS-ENTIRE-FILE NIL PEFP)) (* ; "Edited 25-Feb-2026 23:02 by rmk")
(* ; "Edited 29-Jun-90 19:19 by nm")
(LET
(COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML)
(NLAMA NLAMA)
(LAMS LAMS)
(LAMA LAMA)
(DFNFLG NIL))
(DECLARE (CL:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG))
(RESETLST
(RESETSAVE NIL (LIST 'RESETUNDO)
(RESETUNDO))
(RESETSAVE COUTFILE COMPILER-OUTPUT)
(RESETSAVE STRF REDEFINE)
(RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE 'DEFER))
(RESETSAVE LAPFLG LAP)
(LET
((*PACKAGE* *INTERLISP-PACKAGE*)
(*READ-BASE* 10)
(LOCALVARS SYSLOCALVARS)
(SPECVARS T)
STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM)
(DECLARE (CL:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL))
[RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
(SETQ STREAM (OPENSTREAM FILENAME 'INPUT]
(CL:MULTIPLE-VALUE-SETQ (ENV FORM)
(\PARSE-FILE-HEADER STREAM 'RETURN T))
(SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*)))
(if (NOT PEFP)
then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT))
(if LAP
then (SETQ LSTFIL COUTFILE))
(SETQ FILENAME (FULLNAME STREAM))
(RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET)
[SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING
'VERSION NIL
'EXTENSION COMPILE.EXT
'BODY FILENAME))
'OUTPUT
'NEW
`((TYPE BINARY)
(:EXTERNAL-FORMAT ,ENV]
STREAM
(ROOTFILENAME FILENAME)))
(if OUTPUT-FILE
then (RESETSAVE LCFIL OUTPUT-FILE)
(PRINT-COMPILE-HEADER (LIST STREAM)
'("COMPILE-FILEd")
ENV))
(WITH-READER-ENVIRONMENT ENV
(PROG ((DEFERRED.EXPRESSIONS NIL)
(*PRINT-ARRAY* T)
(*PRINT-LEVEL* NIL)
(*PRINT-LENGTH* NIL)
(FIRSTFORMS NIL)
(AFTERS NIL)
(SCRATCH.LCOM '{CORE}SCRATCH.LCOM)
DUMMYFILE TEMPVAL)
(DECLARE (CL:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL*
*PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS))
(* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)")
[RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
(SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM 'BOTH 'NEW
`((:EXTERNAL-FORMAT ,ENV]
LPDUMP
[if (EQUAL (CAR FORM)
'RPAQQ)
then (* ;
 "This is the support method of %"COMPILERVARS%" (2-July-1990 TT)")
(SETQ TEMPVAL (CADDR FORM))
(if (SETQ TEMPVAL (ASSOC 'DECLARE%: TEMPVAL))
then (if (SETQ TEMPVAL (FMEMB 'COMPILERVARS (FMEMB 'DOEVAL@COMPILE
TEMPVAL)))
then (SETQ DFNFLG T)
(if [SETQ TEMPVAL (FMEMB 'ADDVARS (SETQ TEMPVAL
(CADR TEMPVAL]
then (CL:DOLIST (ARG (CDR TEMPVAL))
(APPLY 'ADDTOVAR ARG))]
(COMPILE-FILE-EXPRESSION FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE)
(SKIPSEPRCODES STREAM)
(if (EOFP STREAM)
then (CLOSEF STREAM)
(for FORM in FIRSTFORMS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL
PROCESS-ENTIRE-FILE T))
(COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE))
(CLOSEF? DUMMYFILE)
(DELFILE (FULLNAME DUMMYFILE))
(CL:WHEN PROCESS-ENTIRE-FILE
(for EXP in (REVERSE DEFERRED.EXPRESSIONS)
do (APPLY* (CAR EXP)
(CDR EXP)
OUTPUT-FILE)))
(for FORM in AFTERS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL
PROCESS-ENTIRE-FILE T))
(RETURN))
(SETQ FORM (READ STREAM))
(GO LPDUMP))
(PRINT NIL OUTPUT-FILE))
(SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE)))) (* ; "Do these after UNDONLSETQ entered")
(MAPC (REVERSE COMPILE.FILE.AFTER)
(FUNCTION EVAL))
COMPILE.FILE.VALUE)))
(INTERLISP-FORMAT-P
[LAMBDA (STREAM) (* bvm%: " 3-Aug-86 14:01")
@@ -302,14 +401,13 @@ Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation.
(ADDTOVAR LAMA FAKE-COMPILE-FILE)
)
(PUTPROPS CMLCOMPILE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1636 2253 (CL:DISASSEMBLE 1636 . 2253)) (2254 17523 (FAKE-COMPILE-FILE 2264 . 5700) (
INTERLISP-FORMAT-P 5702 . 5920) (INTERLISP-NLAMBDA-FUNCTION-P 5922 . 6156) (COMPILE-FILE-EXPRESSION
6158 . 9508) (COMPILE-FILE-WALK-FUNCTION 9510 . 9757) (ARGTYPE.STATE 9759 . 9919) (
COMPILE.CHECK.ARGTYPE 9921 . 11913) (COMPILE.FILE.DEFINEQ 11915 . 12408) (
COMPILE-FILE-SETF-SYMBOL-FUNCTION 12410 . 13004) (COMPILE-FILE-EX/IMPORT 13006 . 13334) (
COMPILE.FILE.APPLY 13336 . 13596) (COMPILE.FILE.RESET 13598 . 14459) (COMPILE-IN-CORE 14461 . 17521))
(17524 19253 (COMPILE-FILE-SCAN-FIRST 17534 . 19251)) (19796 21163 (COMPILE-FILE-DECLARE%: 19796 .
21163)) (21164 22228 (NEWDEFC 21174 . 22226)))))
(FILEMAP (NIL (1569 2186 (CL:DISASSEMBLE 1569 . 2186)) (2187 20243 (FAKE-COMPILE-FILE 2197 . 8420) (
INTERLISP-FORMAT-P 8422 . 8640) (INTERLISP-NLAMBDA-FUNCTION-P 8642 . 8876) (COMPILE-FILE-EXPRESSION
8878 . 12228) (COMPILE-FILE-WALK-FUNCTION 12230 . 12477) (ARGTYPE.STATE 12479 . 12639) (
COMPILE.CHECK.ARGTYPE 12641 . 14633) (COMPILE.FILE.DEFINEQ 14635 . 15128) (
COMPILE-FILE-SETF-SYMBOL-FUNCTION 15130 . 15724) (COMPILE-FILE-EX/IMPORT 15726 . 16054) (
COMPILE.FILE.APPLY 16056 . 16316) (COMPILE.FILE.RESET 16318 . 17179) (COMPILE-IN-CORE 17181 . 20241))
(20244 21973 (COMPILE-FILE-SCAN-FIRST 20254 . 21971)) (22516 23883 (COMPILE-FILE-DECLARE%: 22516 .
23883)) (23884 24948 (NEWDEFC 23894 . 24946)))))
STOP

BIN
sources/CMLCOMPILE.DFASL Normal file
View File

Binary file not shown.

130
sources/CMLREAD
View File

@@ -1,12 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
(FILECREATED "24-Apr-2025 21:59:48" {WMEDLEY}<sources>CMLREAD.;17 12829
(FILECREATED "25-Feb-2026 11:51:19" {WMEDLEY}<sources>CMLREAD.;24 12180
:EDIT-BY rmk
:CHANGES-TO (VARS CMLREADCOMS)
(FUNCTIONS WITH-READER-ENVIRONMENT)
:PREVIOUS-DATE "23-Sep-2024 11:55:33" {WMEDLEY}<sources>CMLREAD.;16)
:PREVIOUS-DATE "25-Feb-2026 09:25:29" {WMEDLEY}<sources>CMLREAD.;21)
(PRETTYCOMPRINT CMLREADCOMS)
@@ -26,18 +27,14 @@
(DWIMINMACROSFLG))
(VARIABLES *READ-DEFAULT-FLOAT-FORMAT*)
(GLOBALVARS CMLRDTBL READ-LINE-RDTBL))
[COMS
(* ;; "Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup")
(RECORDS READER-ENVIRONMENT)
(FUNCTIONS WITH-READER-ENVIRONMENT)
(ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
[COMS (FUNCTIONS WITH-READER-ENVIRONMENT)
(PROP INFO WITH-READER-ENVIRONMENT)
(ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
(GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
(INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _
(INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE ←
(CL:FIND-PACKAGE "USER")
REREADTABLE _ CMLRDTBL REBASE _ 10
REFORMAT _ :MCCS]
REREADTABLE ← CMLRDTBL REBASE ← 10
REFORMAT ← :MCCS]
(PROP FILETYPE CMLREAD)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
@@ -53,48 +50,48 @@
(CL:COPY-READTABLE
[CL:LAMBDA (&OPTIONAL (FROM-READTABLE *READTABLE*)
TO-READTABLE) (* bvm%: "13-Oct-86 15:21")
TO-READTABLE) (* bvm%: "13-Oct-86 15:21")
(* ;
 "If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable is made.")
 "If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable is made.")
(if (AND (NULL FROM-READTABLE)
(NULL TO-READTABLE))
then (* ; "just make a brand new one")
(CMLRDTBL)
(NULL TO-READTABLE))
then (* ; "just make a brand new one")
(CMLRDTBL)
else (SETQ FROM-READTABLE (\DTEST (OR FROM-READTABLE (CMLRDTBL))
'READTABLEP))
(if TO-READTABLE
then (RESETREADTABLE (\DTEST TO-READTABLE 'READTABLEP)
FROM-READTABLE)
TO-READTABLE
else (COPYREADTABLE FROM-READTABLE])
'READTABLEP))
(if TO-READTABLE
then (RESETREADTABLE (\DTEST TO-READTABLE 'READTABLEP)
FROM-READTABLE)
TO-READTABLE
else (COPYREADTABLE FROM-READTABLE])
)
(DEFINEQ
(CL:READ-LINE
[CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T)
EOF-VALUE RECURSIVE-P) (* ; "Edited 31-Mar-87 18:36 by bvm:")
EOF-VALUE RECURSIVE-P) (* ; "Edited 31-Mar-87 18:36 by bvm:")
(* ;;
 "Returns a line of text read from the STREAM as a string, discarding the newline character.")
 "Returns a line of text read from the STREAM as a string, discarding the newline character.")
(CL:SETQ STREAM (\GETSTREAM STREAM 'INPUT))
(if (AND (NULL EOF-ERRORP)
(NULL RECURSIVE-P)
(\EOFP STREAM))
(NULL RECURSIVE-P)
(\EOFP STREAM))
then EOF-VALUE
else (LET ((RESULT (RSTRING STREAM READ-LINE-RDTBL)))
(if (\EOFP STREAM)
then (CL:VALUES RESULT T)
else (* ; "consume the eol")
(READCCODE STREAM)
(CL:VALUES RESULT NIL])
(if (\EOFP STREAM)
then (CL:VALUES RESULT T)
else (* ; "consume the eol")
(READCCODE STREAM)
(CL:VALUES RESULT NIL])
(CL:READ-CHAR
[CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)
(EOF-ERRORP T)
EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 20:41 by bvm:")
EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 20:41 by bvm:")
(* ;; "Inputs a character from STREAM and returns it.")
(* ;; "Inputs a character from STREAM and returns it.")
(LET [(STREAM (\GETSTREAM STREAM 'INPUT]
(COND
@@ -105,10 +102,10 @@
(T (CL:CODE-CHAR (READCCODE STREAM])
(CL:UNREAD-CHAR
(CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*))
(* ; "Edited 23-Jun-2021 13:05 by rmk:")
(CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*))
(* ; "Edited 23-Jun-2021 13:05 by rmk:")
(* ;; "Puts the CHARACTER back on the front of the input STREAM. According to the manual, `One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM.'")
(* ;; "Puts the CHARACTER back on the front of the input STREAM. According to the manual, `One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM.'")
(\BACKCCODE (\GETSTREAM INPUT-STREAM 'INPUT))
NIL))
@@ -153,7 +150,7 @@
else (\ILLEGAL.ARG PEEK-TYPE])
(CL:LISTEN
(CL:LAMBDA (&OPTIONAL STREAM) (* ; "Edited 14-Apr-87 16:49 by bvm:")
(CL:LAMBDA (&OPTIONAL STREAM) (* ; "Edited 14-Apr-87 16:49 by bvm:")
(* ;; "Returns T if a character is available on the given STREAM ")
@@ -162,7 +159,7 @@
(CL:READ-CHAR-NO-HANG
(CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T)
EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Apr-87 16:40 by bvm:")
EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Apr-87 16:40 by bvm:")
(* ;; "Returns the next character from the STREAM if one is available, or NIL. However, if STREAM is at eof, do eof handling.")
@@ -170,13 +167,13 @@
((READP STREAM T) (* ; "there is input, get it")
(CL:READ-CHAR STREAM EOF-ERRORP EOF-VALUE RECURSIVE-P))
((NOT (EOFP STREAM)) (* ;
 "there could be more input, so don't wait, return NIL")
 "there could be more input, so don't wait, return NIL")
NIL)
(EOF-ERRORP (\EOF.ACTION STREAM))
(T EOF-VALUE))))
(CL:CLEAR-INPUT
[CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)) (* bvm%: "13-Oct-86 15:46")
[CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)) (* bvm%: "13-Oct-86 15:46")
(* ;; "Clears any buffered input associated with the Stream.")
@@ -200,7 +197,7 @@
(CL:READ-BYTE
[CL:LAMBDA (BINARY-INPUT-STREAM &OPTIONAL (EOF-ERRORP T)
EOF-VALUE) (* bvm%: "13-Oct-86 15:49")
EOF-VALUE) (* bvm%: "13-Oct-86 15:49")
(* ;; "Returns the next byte of the BINARY-INPUT-STREAM")
@@ -211,7 +208,7 @@
(\BIN STREAM))])
(CL:WRITE-BYTE
(CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM) (* bvm%: "13-Oct-86 15:49")
(CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM) (* bvm%: "13-Oct-86 15:49")
(* ;; "Outputs the INTEGER to the binary BINARY-OUTPUT-STREAM")
@@ -236,47 +233,30 @@
(GLOBALVARS CMLRDTBL READ-LINE-RDTBL)
)
(* ;;
"Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup"
)
(DECLARE%: EVAL@COMPILE
(DATATYPE READER-ENVIRONMENT (REPACKAGE REREADTABLE REBASE REPACKAGEFORM REFORMAT REREADTABLEFORM))
)
(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER)
'((READER-ENVIRONMENT 0 POINTER)
(READER-ENVIRONMENT 2 POINTER)
(READER-ENVIRONMENT 4 POINTER)
(READER-ENVIRONMENT 6 POINTER)
(READER-ENVIRONMENT 8 POINTER)
(READER-ENVIRONMENT 10 POINTER))
'12)
(DEFMACRO WITH-READER-ENVIRONMENT (ENV . BODY)
(DEFMACRO WITH-READER-ENVIRONMENT (ENV . BODY) (* ; "Edited 25-Feb-2026 09:23 by rmk")
`((CL:LAMBDA (E)
(CL:WHEN (\GETSTREAM E 'INPUT T)
(SETQ E (READ-READER-ENVIRONMENT STREAM)))
(\DTEST E 'READER-ENVIRONMENT)
(LET ((*PACKAGE* (ffetch (READER-ENVIRONMENT REPACKAGE) of E))
(*READTABLE* (ffetch (READER-ENVIRONMENT REREADTABLE) of E))
(*READ-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E))
(*PRINT-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E)))
,@BODY))
(\DTEST ,ENV 'READER-ENVIRONMENT)))
(ADDTOVAR SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)
,ENV))
(PUTPROPS WITH-READER-ENVIRONMENT INFO EVAL)
(ADDTOVAR SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
)
(RPAQ? *COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _ (CL:FIND-PACKAGE "USER")
REREADTABLE _ CMLRDTBL REBASE _ 10 REFORMAT _ :MCCS))
(RPAQ? *COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE ← (CL:FIND-PACKAGE "USER")
REREADTABLE ← CMLRDTBL REBASE ← 10 REFORMAT ← :MCCS))
(PUTPROPS CMLREAD FILETYPE CL:COMPILE-FILE)
(PUTPROPS CMLREAD FILETYPE :FAKE-COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
@@ -287,9 +267,9 @@
CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2380 3365 (CL:COPY-READTABLE 2390 . 3363)) (3366 10574 (CL:READ-LINE 3376 . 4248) (
CL:READ-CHAR 4250 . 4800) (CL:UNREAD-CHAR 4802 . 5263) (CL:PEEK-CHAR 5265 . 7559) (CL:LISTEN 7561 .
7826) (CL:READ-CHAR-NO-HANG 7828 . 8600) (CL:CLEAR-INPUT 8602 . 8839) (CL:READ-FROM-STRING 8841 . 9861
) (CL:READ-BYTE 9863 . 10316) (CL:WRITE-BYTE 10318 . 10572)) (11568 12041 (WITH-READER-ENVIRONMENT
11568 . 12041)))))
(FILEMAP (NIL (2210 3182 (CL:COPY-READTABLE 2220 . 3180)) (3183 10389 (CL:READ-LINE 3193 . 4049) (
CL:READ-CHAR 4051 . 4605) (CL:UNREAD-CHAR 4607 . 5068) (CL:PEEK-CHAR 5070 . 7364) (CL:LISTEN 7366 .
7635) (CL:READ-CHAR-NO-HANG 7637 . 8415) (CL:CLEAR-INPUT 8417 . 8654) (CL:READ-FROM-STRING 8656 . 9676
) (CL:READ-BYTE 9678 . 10131) (CL:WRITE-BYTE 10133 . 10387)) (10728 11381 (WITH-READER-ENVIRONMENT
10728 . 11381)))))
STOP

BIN
sources/CMLREAD.LCOM
View File

Binary file not shown.

61
sources/COMPILE
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "24-Apr-2025 22:04:20" {WMEDLEY}<sources>COMPILE.;6 76628
(FILECREATED "26-Feb-2026 10:41:28" {WMEDLEY}<sources>COMPILE.;9 77027
:EDIT-BY rmk
:CHANGES-TO (FNS BCOMPL.BODY BRECOMPILE)
:CHANGES-TO (FNS BRECOMPILE)
:PREVIOUS-DATE "24-Sep-2023 13:59:34" {WMEDLEY}<sources>COMPILE.;5)
:PREVIOUS-DATE "26-Feb-2026 00:46:08" {WMEDLEY}<sources>COMPILE.;8)
(PRETTYCOMPRINT COMPILECOMS)
@@ -104,7 +104,8 @@
CFILE NOBLOCKSFLG OPTIONSSET)))])
(BCOMPL.BODY
[LAMBDA (STREAMS CFILE NOBLOCKSFLG OPTIONSSET) (* ; "Edited 24-Apr-2025 22:03 by rmk")
[LAMBDA (STREAMS CFILE NOBLOCKSFLG OPTIONSSET) (* ; "Edited 26-Feb-2026 00:43 by rmk")
(* ; "Edited 24-Apr-2025 22:03 by rmk")
(* ; "Edited 5-Jul-2021 13:46 by rmk:")
(* ;;; "STREAMS is a list of streams. Compile everything on them, dumping to CFILE (default first stream.dcom). NOBLOCKSFLG means TCOMPL instead of BCOMPL. OPTIONSSET is true if the Listing? question has already been asked.")
@@ -146,7 +147,7 @@
(RESETSAVE NIL (LIST 'CLOSEF STREAM))
(RESETSAVE (INPUT STREAM)) (* ;
 "Needs to be primary input for some of the filepkg expressions to work")
(WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
(WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV*
(until (OR (NULL (SETQ TEM (READ STREAM)))
(EQ TEM 'STOP))
do (CL:WHEN (EQ (CAR (LISTP TEM))
@@ -491,7 +492,9 @@
(SETQ BLOCKS (NCONC1 BLOCKS X))))
(BRECOMPILE
[LAMBDA (FILES CFILE FNS NOBLOCKSFLG) (* ; "Edited 24-Apr-2025 22:04 by rmk")
[LAMBDA (FILES CFILE FNS NOBLOCKSFLG) (* ; "Edited 26-Feb-2026 10:35 by rmk")
(* ; "Edited 24-Feb-2026 10:00 by rmk")
(* ; "Edited 24-Apr-2025 22:04 by rmk")
(* ; "Edited 5-Jul-2021 09:28 by rmk:")
(* ;;; "FNS is a list of functions to be recompiled. The object is to make a file that looks exactly like that produced by BCOMPL except to greatly reduce the work by copying from CFILE the compiled definitions those functions not being recompiled.")
@@ -632,6 +635,7 @@
(DECLARE (CL:SPECIAL FILECREATEDLOC))
(* ; " used by LOADFNSCAN")
(WITH-READER-ENVIRONMENT ENV
(\EXTERNALFORMAT STREAM ENV)
(create COMPFILEDESCR
COMPFILESTREAM _ STREAM
COMPFILEENV _ ENV
@@ -653,8 +657,7 @@
(* ;
 "Start writing the compiled file. Use environment of one of the source files--usually the only one")
(if LCFIL
then (\EXTERNALFORMAT LCFIL (OR (LISTGET DESTINATIONENV :FORMAT)
:MCCS))
then (\EXTERNALFORMAT LCFIL (OR DESTINATIONENV :MCCS))
(PRINT-COMPILE-HEADER
FILES
[CONS (if NOBLOCKSFLG
@@ -851,27 +854,31 @@
(T (GO LP])
(BRECOMPILE3
(LAMBDA (FN FILEMAPLST COREOK) (* bvm%: "29-Aug-86 22:07")
(* * "returns definition of FN, either from in core, or from the file.")
[LAMBDA (FN FILEMAPLST COREOK) (* ; "Edited 24-Feb-2026 09:59 by rmk")
(* bvm%: "29-Aug-86 22:07")
(* ;;; "returns definition of FN, either from in core, or from the file.")
(LET (DEF STREAM)
(COND
((AND COREOK (EXPRP (SETQ DEF (VIRGINFN FN T)))) (* "Value is of the form (FN DEF FLG) where FLG=T means the definition was obtained from in core, so that it is ok to do spelling correction.")
([AND COREOK (EXPRP (SETQ DEF (VIRGINFN FN T]
(* ;; "Value is of the form (FN DEF FLG) where FLG=T means the definition was obtained from in core, so that it is ok to do spelling correction.")
(LIST FN DEF T))
(T (for FILEDESCR in FILEMAPLST
when (PROGN (SETQ STREAM (fetch COMPFILESTREAM of FILEDESCR))
when [PROGN (SETQ STREAM (fetch COMPFILESTREAM of FILEDESCR))
(for Y in (CDR (fetch COMPFILEMAP of FILEDESCR))
thereis (SETQ DEF (FASSOC FN (CDDR Y)))))
thereis (SETQ DEF (FASSOC FN (CDDR Y]
do (SETFILEPTR STREAM (CADR DEF))
(SETQ DEF (WITH-READER-ENVIRONMENT (fetch COMPFILEENV of FILEDESCR)
(READ STREAM))) (*
 "TEM is an arg to DEFINEQ, of the form (fn def)")
(READ STREAM))) (* ;
 "TEM is an arg to DEFINEQ, of the form (fn def)")
(COND
((NEQ FN (CAR DEF))
(ERROR '"filemap does not agree with contents of" (FULLNAME STREAM)
T)))
(RETURN DEF)))))))
(RETURN DEF])
(BLOCKCOMPILE
[LAMBDA (BLKNAME BLKFNS ENTRIES FLG) (* ; "Edited 6-Dec-86 03:59 by lmm")
@@ -1518,14 +1525,14 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3379 73129 (BCOMPL 3389 . 5039) (BCOMPL.BODY 5041 . 11639) (PRINT-COMPILE-HEADER 11641
. 12704) (RESETOPENFILES 12706 . 13059) (BCOMPL1A 13061 . 19074) (BCOMPL2 19076 . 25891) (BCOMPL3
25893 . 27242) (BLOCK%: 27244 . 27876) (BRECOMPILE 27878 . 42562) (BRECOMPILE1 42564 . 48416) (
BRECOMPILE2 48418 . 49220) (BRECOMPILE3 49222 . 50598) (BLOCKCOMPILE 50600 . 52460) (BLOCKCOMPILE1
52462 . 57547) (COMPSET 57549 . 60246) (COMPSETREAD 60248 . 61559) (COMPSETY 61561 . 61685) (COMPSETF
61687 . 61853) (RCOMP3 61855 . 63562) (TCOMPL 63564 . 63863) (RECOMPILE 63865 . 63948) (RECOMP? 63950
. 64410) (COMPILE 64412 . 66401) (COMPILE1 66403 . 66991) (COMPILE1A 66993 . 68640) (
SHOULD-BE-DWIMIFIED? 68642 . 69331) (COMPEM 69333 . 70057) (GETCFILE 70059 . 71790) (SPECVARS 71792 .
72347) (LOCALVARS 72349 . 72923) (GLOBALVARS 72925 . 73127)) (75479 76428 (COMPILEMODE 75489 . 76426))
(FILEMAP (NIL (3367 73528 (BCOMPL 3377 . 5027) (BCOMPL.BODY 5029 . 11726) (PRINT-COMPILE-HEADER 11728
. 12791) (RESETOPENFILES 12793 . 13146) (BCOMPL1A 13148 . 19161) (BCOMPL2 19163 . 25978) (BCOMPL3
25980 . 27329) (BLOCK%: 27331 . 27963) (BRECOMPILE 27965 . 42866) (BRECOMPILE1 42868 . 48720) (
BRECOMPILE2 48722 . 49524) (BRECOMPILE3 49526 . 50997) (BLOCKCOMPILE 50999 . 52859) (BLOCKCOMPILE1
52861 . 57946) (COMPSET 57948 . 60645) (COMPSETREAD 60647 . 61958) (COMPSETY 61960 . 62084) (COMPSETF
62086 . 62252) (RCOMP3 62254 . 63961) (TCOMPL 63963 . 64262) (RECOMPILE 64264 . 64347) (RECOMP? 64349
. 64809) (COMPILE 64811 . 66800) (COMPILE1 66802 . 67390) (COMPILE1A 67392 . 69039) (
SHOULD-BE-DWIMIFIED? 69041 . 69730) (COMPEM 69732 . 70456) (GETCFILE 70458 . 72189) (SPECVARS 72191 .
72746) (LOCALVARS 72748 . 73322) (GLOBALVARS 73324 . 73526)) (75878 76827 (COMPILEMODE 75888 . 76825))
)))
STOP

BIN
sources/COMPILE.LCOM
View File

Binary file not shown.

2438
sources/DWIMIFY
View File

File diff suppressed because it is too large Load Diff

BIN
sources/DWIMIFY.LCOM
View File

Binary file not shown.

175
sources/EXTERNALFORMAT
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
(FILECREATED " 9-Feb-2026 15:54:22" {WMEDLEY}<sources>EXTERNALFORMAT.;120 47422
(FILECREATED "22-Feb-2026 12:29:38" {WMEDLEY}<sources>EXTERNALFORMAT.;124 45411
:EDIT-BY rmk
:CHANGES-TO (VARS EXTERNALFORMATCOMS)
(FNS \CREATE.THROUGH16.EXTERNALFORMAT \CREATE.THROUGH.EXTERNALFORMAT)
:PREVIOUS-DATE " 6-Feb-2026 23:21:32" {WMEDLEY}<sources>EXTERNALFORMAT.;116)
:PREVIOUS-DATE "20-Feb-2026 09:18:35" {WMEDLEY}<sources>EXTERNALFORMAT.;123)
(PRETTYCOMPRINT EXTERNALFORMATCOMS)
@@ -23,9 +22,6 @@
(EXPORT (GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*))
(INITVARS (*EXTERNALFORMATS* NIL)
(*DEFAULT-EXTERNALFORMAT* :MCCS))
(COMS (FNS SYSTEM-EXTERNALFORMAT MTOSYSSTRING SYSTOMSTRING)
(EXPORT (GLOBALVARS *SYSTEM-EXTERNALFORMAT*))
(INITVARS (*SYSTEM-EXTERNALFORMAT* :UTF-8)))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'EXTERNALFORMAT (FUNCTION
\EXTERNALFORMAT.DEFPRINT
]
@@ -243,18 +239,18 @@
(NIL)
(SHOULDNT)))
(\INSTALL.EXTERNALFORMAT (CREATE EXTERNALFORMAT
NAME _ NAME
INCCODEFN _ INCCODEFN
PEEKCCODEFN _ PEEKCCODEFN
BACKCCODEFN _ BACKCCODEFN
OUTCHARFN _ OUTCHARFN
FORMATBYTESTREAMFN _ FORMATBYTESTREAMFN
EOLVALID _ EOL
EOL _ (OR EOL LF.EOLC)
UNSTABLE _ UNSTABLE
MCCSTOFORMATBYTESFN _ MCCSTOFORMATBYTESFN
FORMATBYTESTOMCCSFN _ FORMATBYTESTOMCCSFN
FORMATCHARSETFN _ (OR FORMATCHARSETFN (FUNCTION NILL])
NAME ← NAME
INCCODEFN ← INCCODEFN
PEEKCCODEFN ← PEEKCCODEFN
BACKCCODEFN ← BACKCCODEFN
OUTCHARFN ← OUTCHARFN
FORMATBYTESTREAMFN ← FORMATBYTESTREAMFN
EOLVALID ← EOL
EOL ← (OR EOL LF.EOLC)
UNSTABLE ← UNSTABLE
MCCSTOFORMATBYTESFN ← MCCSTOFORMATBYTESFN
FORMATBYTESTOMCCSFN ← FORMATBYTESTOMCCSFN
FORMATCHARSETFN ← (OR FORMATCHARSETFN (FUNCTION NILL])
(\EXTERNALFORMAT.DEFPRINT
[LAMBDA (EXTERNALFORMAT STREAM) (* ; "Edited 2-Jul-2022 11:40 by rmk")
@@ -268,7 +264,7 @@
(DEFINEQ
(\INSTALL.EXTERNALFORMAT
[LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:")
[LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:")
(* ;;; "Register an instance of the datatype EXTERNALFORMAT.")
@@ -277,25 +273,23 @@
(LET (NAME)
(IF EXTERNALFORMAT
THEN
(* ;; "Backwards compatibility")
(* ;; "Backwards compatibility")
(SETQ NAME (MKATOM EXTFORMAT/NAME))
(IF (EQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT))
ELSEIF (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)
THEN (ERROR "Mismatch of specified name and name of the external format")
ELSE (REPLACE (EXTERNALFORMAT NAME) OF EXTERNALFORMAT WITH
NAME))
(SETQ NAME (MKATOM EXTFORMAT/NAME))
(IF (EQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT))
ELSEIF (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)
THEN (ERROR "Mismatch of specified name and name of the external format")
ELSE (REPLACE (EXTERNALFORMAT NAME) OF EXTERNALFORMAT WITH NAME))
ELSE (SETQ EXTERNALFORMAT EXTFORMAT/NAME)
(SETQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)))
(SETQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)))
(IF (type? EXTERNALFORMAT EXTERNALFORMAT)
THEN (\REMOVE.EXTERNALFORMAT NAME)
(push *EXTERNALFORMATS* EXTERNALFORMAT)
(push *EXTERNALFORMATS* EXTERNALFORMAT)
ELSE (ERROR "INVALID EXTERNALFORMAT " EXTERNALFORMAT))
EXTERNALFORMAT])
(\REMOVE.EXTERNALFORMAT
[LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:")
[LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:")
(* ;;; "Deregisters external format EXTERNALFORMAT .")
@@ -303,9 +297,8 @@
THEN (FETCH (EXTERNALFORMAT NAME) OF NAME/EXTFORMAT)
ELSE (MKATOM NAME/EXTFORMAT)))
(SETQ *EXTERNALFORMATS* (DREMOVE (FIND EF IN *EXTERNALFORMATS*
SUCHTHAT (EQ NAME/EXTFORMAT (FETCH (EXTERNALFORMAT
NAME)
OF EF)))
SUCHTHAT (EQ NAME/EXTFORMAT (FETCH (EXTERNALFORMAT NAME)
OF EF)))
*EXTERNALFORMATS*])
(FIND-FORMAT
@@ -330,41 +323,6 @@
(RPAQ? *EXTERNALFORMATS* NIL)
(RPAQ? *DEFAULT-EXTERNALFORMAT* :MCCS)
(DEFINEQ
(SYSTEM-EXTERNALFORMAT
[LAMBDA NIL (* ; "Edited 6-Feb-2026 11:29 by rmk")
(* ; "Edited 31-Jan-2026 18:51 by rmk")
(* ; "Edited 10-Oct-2022 11:55 by lmm")
(* ; "Edited 7-Jul-2022 10:41 by rmk")
(* ;; "Returns the name, sets the global. For now, UTF-8 or through, could be something else.")
(fetch (EXTERNALFORMAT NAME) of (SETQ *SYSTEM-EXTERNALFORMAT*
(FIND-FORMAT (FOR X IN '("LC¬CTYPE" "LC¬ALL" "LANG")
WHEN (STRPOS ".UTF-8" (UNIX-GETENV X))
DO (RETURN :UTF-8) FINALLY (RETURN :THROUGH])
(MTOSYSSTRING
[LAMBDA (MSTRING) (* ; "Edited 6-Feb-2026 00:20 by rmk")
(MCCSTOFORMATBYTES *SYSTEM-EXTERNALFORMAT* (MKSTRING MSTRING])
(SYSTOMSTRING
[LAMBDA (SYSTRING) (* ; "Edited 5-Feb-2026 23:36 by rmk")
(* ;; "SYSSTRING is presumably shared with Unix, guarantee a copy on the way out")
(CONCAT (FORMATBYTESTOMCCS *SYSTEM-EXTERNALFORMAT* SYSTRING])
)
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *SYSTEM-EXTERNALFORMAT*)
)
(* "END EXPORTED DEFINITIONS")
(RPAQ? *SYSTEM-EXTERNALFORMAT* :UTF-8)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(DEFPRINT 'EXTERNALFORMAT (FUNCTION \EXTERNALFORMAT.DEFPRINT))
@@ -730,41 +688,41 @@
(* ;; "Defines the NULL device, an infinite source or sink")
(\DEFINEDEVICE 'NULL (create FDEV
DEVICENAME _ 'NULL
RANDOMACCESSP _ T
NODIRECTORIES _ T
CLOSEFILE _ (FUNCTION NILL)
DELETEFILE _ (FUNCTION NILL)
OPENFILE _ (FUNCTION \NULL.OPENFILE)
REOPENFILE _ (FUNCTION \NULL.OPENFILE)
BIN _ (FUNCTION \EOF.ACTION)
BOUT _ (FUNCTION NILL)
PEEKBIN _ [FUNCTION (LAMBDA (STREAM NOERRORFLG)
DEVICENAME ← 'NULL
RANDOMACCESSP ← T
NODIRECTORIES ← T
CLOSEFILE ← (FUNCTION NILL)
DELETEFILE ← (FUNCTION NILL)
OPENFILE ← (FUNCTION \NULL.OPENFILE)
REOPENFILE ← (FUNCTION \NULL.OPENFILE)
BIN ← (FUNCTION \EOF.ACTION)
BOUT ← (FUNCTION NILL)
PEEKBIN ← [FUNCTION (LAMBDA (STREAM NOERRORFLG)
(AND (NULL NOERRORFLG)
(BIN STREAM]
READP _ (FUNCTION NILL)
BACKFILEPTR _ (FUNCTION NILL)
EOFP _ (FUNCTION TRUE)
RENAMEFILE _ (FUNCTION NILL)
GETFILENAME _ (FUNCTION NILL)
EVENTFN _ (FUNCTION NILL)
BLOCKIN _ (FUNCTION \EOF.ACTION)
BLOCKOUT _ (FUNCTION NILL)
GENERATEFILES _ (FUNCTION \NULLFILEGENERATOR)
GETFILEPTR _ (FUNCTION ZERO)
GETEOFPTR _ (FUNCTION ZERO)
SETFILEPTR _ (FUNCTION NILL)
GETFILEINFO _ (FUNCTION NILL)
SETFILEINFO _ (FUNCTION NILL)
SETEOFPTR _ (FUNCTION NILL])
READP ← (FUNCTION NILL)
BACKFILEPTR ← (FUNCTION NILL)
EOFP ← (FUNCTION TRUE)
RENAMEFILE ← (FUNCTION NILL)
GETFILENAME ← (FUNCTION NILL)
EVENTFN ← (FUNCTION NILL)
BLOCKIN ← (FUNCTION \EOF.ACTION)
BLOCKOUT ← (FUNCTION NILL)
GENERATEFILES ← (FUNCTION \NULLFILEGENERATOR)
GETFILEPTR ← (FUNCTION ZERO)
GETEOFPTR ← (FUNCTION ZERO)
SETFILEPTR ← (FUNCTION NILL)
GETFILEINFO ← (FUNCTION NILL)
SETFILEINFO ← (FUNCTION NILL)
SETEOFPTR ← (FUNCTION NILL])
(\NULL.OPENFILE
[LAMBDA (NAME ACCESS RECOG PARAMETERS DEVICE OLDSTREAM) (* bvm%: "30-Jan-85 22:05")
(OR OLDSTREAM (create STREAM
USERCLOSEABLE _ T
ACCESS _ ACCESS
FULLFILENAME _ NIL
DEVICE _ DEVICE])
USERCLOSEABLE ← T
ACCESS ← ACCESS
FULLFILENAME ← NIL
DEVICE ← DEVICE])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
@@ -883,15 +841,14 @@
(\CREATE.THROUGH16.EXTERNALFORMAT)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (7446 15343 (\EXTERNALFORMAT 7456 . 12055) (MAKE-EXTERNALFORMAT 12057 . 14870) (
\EXTERNALFORMAT.DEFPRINT 14872 . 15341)) (15344 18385 (\INSTALL.EXTERNALFORMAT 15354 . 16803) (
\REMOVE.EXTERNALFORMAT 16805 . 17636) (FIND-FORMAT 17638 . 18383)) (18628 20078 (SYSTEM-EXTERNALFORMAT
18638 . 19586) (MTOSYSSTRING 19588 . 19785) (SYSTOMSTRING 19787 . 20076)) (20442 34717 (\OUTCHAR
20452 . 21669) (\INCCODE 21671 . 22824) (\BACKCCODE 22826 . 24505) (\BACKCCODE.EOLC 24507 . 26697) (
\PEEKCCODE 26699 . 27024) (\PEEKCCODE.EOLC 27026 . 27405) (\INCCODE.EOLC 27407 . 29206) (
\FORMATBYTESTREAM 29208 . 31652) (\CHECKEOLC.CRLF 31654 . 34715)) (34718 38634 (MCCSTOFORMATBYTES
34728 . 37127) (FORMATBYTESTOMCCS 37129 . 38632)) (40045 42281 (\NULLDEVICE 40055 . 41957) (
\NULL.OPENFILE 41959 . 42279)) (42371 47286 (\CREATE.THROUGH.EXTERNALFORMAT 42381 . 44050) (
\CREATE.THROUGH16.EXTERNALFORMAT 44052 . 46243) (\THROUGHIN 46245 . 46669) (\THROUGHBACKCCODE 46671 .
46942) (\THROUGHOUTCHARFN 46944 . 47284)))))
(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.

128
sources/FILEPKG
View File

@@ -1,14 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "27-Sep-2025 19:56:28" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>FILEPKG.;53 274937
(FILECREATED "25-Feb-2026 10:07:03" {WMEDLEY}<sources>FILEPKG.;61 275774
:EDIT-BY rmk
:CHANGES-TO (FNS COMPILE-FILE?)
:CHANGES-TO (FNS FILEGETDEF.FNS)
:PREVIOUS-DATE "24-Apr-2025 11:18:44"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>FILEPKG.;52)
:PREVIOUS-DATE "23-Feb-2026 00:54:21" {WMEDLEY}<sources>FILEPKG.;59)
(PRETTYCOMPRINT FILEPKGCOMS)
@@ -2910,18 +2908,20 @@ compiling " T)
NIL) finally (RETURN 'NOBIND])
(FILEGETDEF.FNS
[LAMBDA (NAME TYPE SOURCE OPTIONS) (* bvm%: "29-Aug-86 22:30")
[LAMBDA (NAME TYPE SOURCE OPTIONS) (* ; "Edited 25-Feb-2026 10:06 by rmk")
(* ; "Edited 23-Feb-2026 00:37 by rmk")
(* bvm%: "29-Aug-86 22:30")
(LET (MAP ENV)
(COND
[(AND (EQMEMB 'FAST OPTIONS)
(PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
(GET-ENVIRONMENT-AND-FILEMAP SOURCE))
MAP))
(CL:UNLESS (OPENP SOURCE)
[RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT 'OLD])
(\EXTERNALFORMAT SOURCE ENV)
(for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME (CDDR PAIR]
do [OR (OPENP SOURCE)
(RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
'OLD]
(SETFILEPTR SOURCE MAPLOC)
do (SETFILEPTR SOURCE MAPLOC)
(RETURN (WITH-READER-ENVIRONMENT ENV
[COND
((EQMEMB 'ARGLIST OPTIONS)
@@ -2931,7 +2931,12 @@ compiling " T)
(LIST (READ SOURCE)
(READ SOURCE)))
(T (CADR (READ SOURCE])]
(T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])
(T
(* ;; "RMK: The NLSETQ is because LOADFNS for FNS seems to disregard NOERROR and crash out when the target is FUNCTIONS, like WITH-READER-ENVIRONMENT")
(CADR (FASSOC NAME (CL:IF (EQMEMB 'NOERROR OPTIONS)
[CAR (NLSETQ (LOADFNS NAME SOURCE 'GETDEF]
(LOADFNS NAME SOURCE 'GETDEF))])
(FILEPKGCOMS.PUTDEF
[LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "15-Jul-85 11:29")
@@ -3335,7 +3340,8 @@ compiling " T)
(RETFROM 'GETDEFCOM])
(GETDEFCURRENT
[LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 2-May-87 19:00 by Pavel")
[LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 23-Feb-2026 00:27 by rmk")
(* ; "Edited 2-May-87 19:00 by Pavel")
(* ;
 "Gets the current definition--source=0")
(LET
@@ -3422,6 +3428,7 @@ compiling " T)
(RESETSAVE PRETTYFLG)
(RESETSAVE FONTCHANGEFLG)
[RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
(\EXTERNALFORMAT FILE *OLD-INTERLISP-READ-ENVIRONMENT*)
(PRETTYDEFCOMS COMS)
(SETFILEPTR FILE 0)
[SETQ DEF
@@ -4689,11 +4696,14 @@ compiling " T)
(AND RETURNFLG (LIST FORM])
(IMPORTFILESCAN
[LAMBDA (FILE RETURNFLG) (* bvm%: "24-Oct-86 19:31")
(WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
(while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
join (until (EQUAL (SETQ DEF (READ FILE))
ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])
[LAMBDA (FILE RETURNFLG) (* ; "Edited 22-Feb-2026 18:20 by rmk")
(* bvm%: "24-Oct-86 19:31")
(LET ((ENV (GET-ENVIRONMENT-AND-FILEMAP FILE)))
(WITH-READER-ENVIRONMENT ENV
(\EXTERNALFORMAT FILE ENV)
(while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
join (until (EQUAL (SETQ DEF (READ FILE))
ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])
(CHECKIMPORTS
[LAMBDA (FILES NOASKFLG) (* rmk%: "19-FEB-83 16:31")
@@ -4868,46 +4878,46 @@ compiling " T)
(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (18974 20647 (SEARCHPRETTYTYPELST 18984 . 19953) (PRETTYDEFMACROS 19955 . 20391) (
FILEPKGCOMPROPS 20393 . 20645)) (21460 55859 (CLEANUP 21470 . 22860) (COMPILEFILES 22862 . 23138) (
COMPILEFILES0 23140 . 23953) (CONTINUEDIT 23955 . 25332) (MAKEFILE 25334 . 37060) (FILECHANGES 37062
. 39826) (FILEPKG.MERGECHANGES 39828 . 40463) (FILEPKG.CHANGEDFNS 40465 . 40777) (MAKEFILE1 40779 .
44991) (COMPILE-FILE? 44993 . 46687) (MAKEFILES 46689 . 48217) (ADDFILE 48219 . 50762) (ADDFILE0 50764
. 54888) (LISTFILES 54890 . 55857)) (56531 90330 (FILEPKGCHANGES 56541 . 57720) (GETFILEPKGTYPE 57722
. 60672) (MARKASCHANGED 60674 . 62305) (FILECOMS 62307 . 62691) (WHEREIS 62693 . 64435) (
SMASHFILECOMS 64437 . 64665) (FILEFNSLST 64667 . 64833) (FILECOMSLST 64835 . 65321) (UPDATEFILES 65323
. 69821) (INFILECOMS? 69823 . 71666) (INFILECOMTAIL 71668 . 72786) (INFILECOMS 72788 . 72949) (
INFILECOM 72951 . 82969) (INFILECOMSVALS 82971 . 83278) (INFILECOMSVAL 83280 . 84288) (INFILECOMSPROP
84290 . 85083) (IFCPROPS 85085 . 86165) (IFCEXPRTYPE 86167 . 86783) (IFCPROPSCAN 86785 . 87746) (
IFCDECLARE 87748 . 89007) (INFILEPAIRS 89009 . 89308) (INFILECOMSMACRO 89310 . 90328)) (90365 121051 (
FILES? 90375 . 92486) (FILES?1 92488 . 93190) (FILES?PRINTLST 93192 . 93974) (ADDTOFILES? 93976 .
104519) (ADDTOFILE 104521 . 105437) (WHATIS 105439 . 107415) (ADDTOCOMS 107417 . 108955) (ADDTOCOM
108957 . 115444) (ADDTOCOM1 115446 . 116617) (ADDNEWCOM 116619 . 117669) (MAKENEWCOM 117671 . 119518)
(DEFAULTMAKENEWCOM 119520 . 121049)) (121121 123938 (MERGEINSERT 121131 . 123474) (MERGEINSERT1 123476
. 123936)) (124092 125453 (ADDTOFILEKEYLST 124102 . 125451)) (125570 136371 (DELFROMFILES 125580 .
126410) (DELFROMCOMS 126412 . 128091) (DELFROMCOM 128093 . 133858) (DELFROMCOM1 133860 . 134659) (
REMOVEITEM 134661 . 135537) (MOVETOFILE 135539 . 136369)) (136585 138956 (SAVEPUT 136595 . 138954)) (
139081 147324 (UNMARKASCHANGED 139091 . 140575) (PREEDITFN 140577 . 143058) (POSTEDITPROPS 143060 .
145354) (POSTEDITALISTS 145356 . 147322)) (147469 166939 (ALISTS.GETDEF 147479 . 147858) (
ALISTS.WHENCHANGED 147860 . 148506) (CLEARCLISPARRAY 148508 . 149686) (EXPRESSIONS.WHENCHANGED 149688
. 150066) (MAKEALISTCOMS 150068 . 151083) (MAKEFILESCOMS 151085 . 152415) (MAKELISPXMACROSCOMS 152417
. 154435) (MAKEPROPSCOMS 154437 . 155063) (MAKEUSERMACROSCOMS 155065 . 156882) (PROPS.WHENCHANGED
156884 . 157505) (FILEGETDEF.LISPXMACROS 157507 . 158806) (FILEGETDEF.ALISTS 158808 . 159399) (
FILEGETDEF.RECORDS 159401 . 160328) (FILEGETDEF.PROPS 160330 . 161125) (FILEGETDEF.MACROS 161127 .
162009) (FILEGETDEF.VARS 162011 . 162614) (FILEGETDEF.FNS 162616 . 163856) (FILEPKGCOMS.PUTDEF 163858
. 165800) (FILES.PUTDEF 165802 . 166670) (VARS.PUTDEF 166672 . 166815) (FILES.WHENCHANGED 166817 .
166937)) (168961 176192 (RENAME 168971 . 170416) (CHANGECALLERS 170418 . 176190)) (176193 224102 (
SHOWDEF 176203 . 177400) (COPYDEF 177402 . 180150) (GETDEF 180152 . 182695) (GETDEFCOM 182697 . 183663
) (GETDEFCOM0 183665 . 184858) (GETDEFCURRENT 184860 . 191172) (GETDEFERR 191174 . 192444) (
GETDEFFROMFILE 192446 . 196675) (GETDEFSAVED 196677 . 197765) (PUTDEF 197767 . 198474) (EDITDEF 198476
. 199459) (DEFAULT.EDITDEF 199461 . 202299) (EDITDEF.FILES 202301 . 202506) (LOADDEF 202508 . 202684)
(DWIMDEF 202686 . 203540) (DELDEF 203542 . 206436) (DELFROMLIST 206438 . 206942) (HASDEF 206944 .
213181) (GETFILEDEF 213183 . 213695) (SAVEDEF 213697 . 215385) (UNSAVEDEF 215387 . 216283) (
COMPAREDEFS 216285 . 220091) (COMPARE 220093 . 220797) (TYPESOF 220799 . 224100)) (224252 232500 (
FILEPKGCOM 224262 . 229038) (FILEPKGTYPE 229040 . 232498)) (244533 262222 (FINDCALLERS 244543 . 245173
) (EDITCALLERS 245175 . 256106) (EDITFROMFILE 256108 . 261537) (FINDATS 261539 . 261811) (LOOKIN
261813 . 262220)) (262223 263894 (SEPRCASE 262233 . 263892)) (264411 269414 (IMPORTFILE 264421 .
265391) (IMPORTEVAL 265393 . 266279) (IMPORTFILESCAN 266281 . 266694) (CHECKIMPORTS 266696 . 267952) (
GATHEREXPORTS 267954 . 268822) (\DUMPEXPORTS 268824 . 269412)) (269752 271822 (CLEARFILEPKG 269762 .
271820)))))
(FILEMAP (NIL (18893 20566 (SEARCHPRETTYTYPELST 18903 . 19872) (PRETTYDEFMACROS 19874 . 20310) (
FILEPKGCOMPROPS 20312 . 20564)) (21379 55778 (CLEANUP 21389 . 22779) (COMPILEFILES 22781 . 23057) (
COMPILEFILES0 23059 . 23872) (CONTINUEDIT 23874 . 25251) (MAKEFILE 25253 . 36979) (FILECHANGES 36981
. 39745) (FILEPKG.MERGECHANGES 39747 . 40382) (FILEPKG.CHANGEDFNS 40384 . 40696) (MAKEFILE1 40698 .
44910) (COMPILE-FILE? 44912 . 46606) (MAKEFILES 46608 . 48136) (ADDFILE 48138 . 50681) (ADDFILE0 50683
. 54807) (LISTFILES 54809 . 55776)) (56450 90249 (FILEPKGCHANGES 56460 . 57639) (GETFILEPKGTYPE 57641
. 60591) (MARKASCHANGED 60593 . 62224) (FILECOMS 62226 . 62610) (WHEREIS 62612 . 64354) (
SMASHFILECOMS 64356 . 64584) (FILEFNSLST 64586 . 64752) (FILECOMSLST 64754 . 65240) (UPDATEFILES 65242
. 69740) (INFILECOMS? 69742 . 71585) (INFILECOMTAIL 71587 . 72705) (INFILECOMS 72707 . 72868) (
INFILECOM 72870 . 82888) (INFILECOMSVALS 82890 . 83197) (INFILECOMSVAL 83199 . 84207) (INFILECOMSPROP
84209 . 85002) (IFCPROPS 85004 . 86084) (IFCEXPRTYPE 86086 . 86702) (IFCPROPSCAN 86704 . 87665) (
IFCDECLARE 87667 . 88926) (INFILEPAIRS 88928 . 89227) (INFILECOMSMACRO 89229 . 90247)) (90284 120970 (
FILES? 90294 . 92405) (FILES?1 92407 . 93109) (FILES?PRINTLST 93111 . 93893) (ADDTOFILES? 93895 .
104438) (ADDTOFILE 104440 . 105356) (WHATIS 105358 . 107334) (ADDTOCOMS 107336 . 108874) (ADDTOCOM
108876 . 115363) (ADDTOCOM1 115365 . 116536) (ADDNEWCOM 116538 . 117588) (MAKENEWCOM 117590 . 119437)
(DEFAULTMAKENEWCOM 119439 . 120968)) (121040 123857 (MERGEINSERT 121050 . 123393) (MERGEINSERT1 123395
. 123855)) (124011 125372 (ADDTOFILEKEYLST 124021 . 125370)) (125489 136290 (DELFROMFILES 125499 .
126329) (DELFROMCOMS 126331 . 128010) (DELFROMCOM 128012 . 133777) (DELFROMCOM1 133779 . 134578) (
REMOVEITEM 134580 . 135456) (MOVETOFILE 135458 . 136288)) (136504 138875 (SAVEPUT 136514 . 138873)) (
139000 147243 (UNMARKASCHANGED 139010 . 140494) (PREEDITFN 140496 . 142977) (POSTEDITPROPS 142979 .
145273) (POSTEDITALISTS 145275 . 147241)) (147388 167392 (ALISTS.GETDEF 147398 . 147777) (
ALISTS.WHENCHANGED 147779 . 148425) (CLEARCLISPARRAY 148427 . 149605) (EXPRESSIONS.WHENCHANGED 149607
. 149985) (MAKEALISTCOMS 149987 . 151002) (MAKEFILESCOMS 151004 . 152334) (MAKELISPXMACROSCOMS 152336
. 154354) (MAKEPROPSCOMS 154356 . 154982) (MAKEUSERMACROSCOMS 154984 . 156801) (PROPS.WHENCHANGED
156803 . 157424) (FILEGETDEF.LISPXMACROS 157426 . 158725) (FILEGETDEF.ALISTS 158727 . 159318) (
FILEGETDEF.RECORDS 159320 . 160247) (FILEGETDEF.PROPS 160249 . 161044) (FILEGETDEF.MACROS 161046 .
161928) (FILEGETDEF.VARS 161930 . 162533) (FILEGETDEF.FNS 162535 . 164309) (FILEPKGCOMS.PUTDEF 164311
. 166253) (FILES.PUTDEF 166255 . 167123) (VARS.PUTDEF 167125 . 167268) (FILES.WHENCHANGED 167270 .
167390)) (169414 176645 (RENAME 169424 . 170869) (CHANGECALLERS 170871 . 176643)) (176646 224749 (
SHOWDEF 176656 . 177853) (COPYDEF 177855 . 180603) (GETDEF 180605 . 183148) (GETDEFCOM 183150 . 184116
) (GETDEFCOM0 184118 . 185311) (GETDEFCURRENT 185313 . 191819) (GETDEFERR 191821 . 193091) (
GETDEFFROMFILE 193093 . 197322) (GETDEFSAVED 197324 . 198412) (PUTDEF 198414 . 199121) (EDITDEF 199123
. 200106) (DEFAULT.EDITDEF 200108 . 202946) (EDITDEF.FILES 202948 . 203153) (LOADDEF 203155 . 203331)
(DWIMDEF 203333 . 204187) (DELDEF 204189 . 207083) (DELFROMLIST 207085 . 207589) (HASDEF 207591 .
213828) (GETFILEDEF 213830 . 214342) (SAVEDEF 214344 . 216032) (UNSAVEDEF 216034 . 216930) (
COMPAREDEFS 216932 . 220738) (COMPARE 220740 . 221444) (TYPESOF 221446 . 224747)) (224899 233147 (
FILEPKGCOM 224909 . 229685) (FILEPKGTYPE 229687 . 233145)) (245180 262869 (FINDCALLERS 245190 . 245820
) (EDITCALLERS 245822 . 256753) (EDITFROMFILE 256755 . 262184) (FINDATS 262186 . 262458) (LOOKIN
262460 . 262867)) (262870 264541 (SEPRCASE 262880 . 264539)) (265058 270251 (IMPORTFILE 265068 .
266038) (IMPORTEVAL 266040 . 266926) (IMPORTFILESCAN 266928 . 267531) (CHECKIMPORTS 267533 . 268789) (
GATHEREXPORTS 268791 . 269659) (\DUMPEXPORTS 269661 . 270249)) (270589 272659 (CLEARFILEPKG 270599 .
272657)))))
STOP

BIN
sources/FILEPKG.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

595
sources/FONT
View File

File diff suppressed because it is too large Load Diff

BIN
sources/FONT.LCOM
View File

Binary file not shown.

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.

385
sources/LOADFNS
View File

@@ -1,20 +1,18 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-May-2022 11:38:55" {DSK}<home>larry>medley>sources>LOADFNS.;2 47218
(FILECREATED "25-Feb-2026 01:03:38" {WMEDLEY}<sources>LOADFNS.;8 47522
:CHANGES-TO (FNS SCANFILEHELP)
:EDIT-BY rmk
:PREVIOUS-DATE "16-Apr-2018 17:38:16" {DSK}<home>larry>medley>sources>LOADFNS.;1)
:CHANGES-TO (VARS LOADFNSCOMS)
:PREVIOUS-DATE "23-Feb-2026 00:49:17" {WMEDLEY}<sources>LOADFNS.;7)
(* ; "
Copyright (c) 1983-1984, 1986-1987, 1989-1990, 2018, 2022 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT LOADFNSCOMS)
(RPAQQ LOADFNSCOMS
[(FNS LOADFROM LOADBLOCK GETBLOCKDEC LOADCOMP LOADCOMP? LOADVARS LOADEFS LOADFILEMAP LOADFNS
[(FNS LOADFROM LOADBLOCK GETBLOCKDEC LOADCOMP LOADCOMP? LOADVARS LOADFILEMAP LOADFNS
LOADFNS-FINDFILE LOADFNS-MAKELIST)
(FNS LOADFNSCAN SCANFILE0 SCANCOMPILEDFN SCANDEFINEQ SCANEXP SCANDECLARECOLON SCANFILE1
SCANFILE2 TMPSUBFN RETRYSCAN SCANFILEHELP)
@@ -98,10 +96,6 @@ Copyright (c) 1983-1984, 1986-1987, 1989-1990, 2018, 2022 by Venue & Xerox Corpo
[LAMBDA (VARS FILE LDFLG)
(LOADFNS NIL FILE LDFLG VARS])
(LOADEFS
[LAMBDA (FNS FILE) (* wt%: " 9-APR-80 20:27")
(LOADFNS FNS FILE 'GETDEF])
(LOADFILEMAP
[LAMBDA (FILE) (* wt%: "16-MAY-79 22:05")
@@ -110,107 +104,107 @@ Copyright (c) 1983-1984, 1986-1987, 1989-1990, 2018, 2022 by Venue & Xerox Corpo
(LOADFNS NIL FILE NIL 'FILEMAP])
(LOADFNS
[LAMBDA (FNS FILE LDFLG VARS) (* bvm%: "17-Nov-86 23:28")
[LAMBDA (FNS FILE LDFLG VARS) (* ; "Edited 23-Feb-2026 00:49 by rmk")
(* bvm%: "17-Nov-86 23:28")
(* ;;; "All of LOADVARS, LOADCOMP, LOADFILEMAP, LOADFROM come thru here.")
(* ;;; "All of LOADVARS, LOADCOMP, LOADFILEMAP, LOADFROM come thru here.")
(DECLARE (SPECVARS FILE LDFLG VARS)) (* ; "Used free by RETRYSCAN")
(DECLARE (SPECVARS FILE LDFLG VARS)) (* ; "Used free by RETRYSCAN")
(RESETLST
(PROG ((*PACKAGE* *INTERLISP-PACKAGE*)
(DFNFLG DFNFLG)
(BUILDMAPFLG BUILDMAPFLG)
(FILEPKGFLG FILEPKGFLG)
(ADDSPELLFLG ADDSPELLFLG)
(LISPXHIST LISPXHIST)
(FILECREATEDLST)
(PRLST (AND FILEPKGFLG (FILEPKGCHANGES)))
INSTREAM FNLST VARLST DONELST ROOTNAME FILEMAP TEM FILEMAPEND FILECREATEDLOC FILENV
RESETSAVER MAPUPDATED)
(DECLARE (SPECVARS *PACKAGE* DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FNLST
VARLST DONELST FILECREATEDLST FILECREATEDLOC))
(* ;
 "FILECREATEDLST is set by SCANEXP when it encounters a FILECREATED expression")
TOP (COND
((OR (EQ LDFLG 'EXPRESSIONS)
(EQ LDFLG 'GETDEF)
(MEMB LDFLG LOADOPTIONS))
(SETQ DFNFLG LDFLG))
((AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T)))
(SETQ LDFLG TEM)
(SETQ DFNFLG LDFLG))
(T (SETQ LDFLG (ERROR "unrecognized load option" LDFLG))
(GO TOP)))
(COND
((EQ LDFLG 'SYSLOAD)
(SETQ DFNFLG T)
(SETQ ADDSPELLFLG NIL)
(SETQ BUILDMAPFLG NIL)
(SETQ FILEPKGFLG NIL)
(SETQ LISPXHIST NIL)))
[AND LISPXHIST (COND
((SETQ TEM (FMEMB 'SIDE LISPXHIST))
(FRPLACA (CADR TEM)
-1))
(T (LISPXPUT 'SIDE (LIST -1)
NIL LISPXHIST] (* ;
 "So that UNDOSAVE will keep saving regardless of how many undosaves are involved")
(SETQ FNLST (LOADFNS-MAKELIST FNS T)) (* ; "Get list of functions")
[COND
((NULL FILE) (* ;
 "Infer what file caller meant (this is a feature!)")
(SETQ FILE (LOADFNS-FINDFILE (CAR FNLST]
RETRY
[RESETSAVE NIL (SETQ RESETSAVER (LIST 'CLOSEF? (SETQ INSTREAM (OPENSTREAM FILE
'INPUT]
(* ;
 "CLOSEF? not CLOSEF because UPDATEFILEMAP might close file for us")
(RESETSAVE (INPUT INSTREAM))
(SETQ FILE (FULLNAME INSTREAM)) (* ;
 "Gets full file name. Also note that there may have been some error correction done in OPENSTREAM")
(COND
((NOT (RANDACCESSP INSTREAM))
(SETQ FILE (ERROR FILE "not a random access file"))
(GO RETRY)))
(SETFILEPTR INSTREAM 0)
(SETQ ROOTNAME (ROOTFILENAME FILE))
(CL:MULTIPLE-VALUE-SETQ (FILENV FILEMAP FILECREATEDLOC FILECREATEDLST)
(GET-ENVIRONMENT-AND-FILEMAP INSTREAM))
(SETQ VARLST (SELECTQ VARS
(NIL NIL)
(VARS (* ;
 "Means load, i.e., evaluate, ALL rpaq/rpaqq")
'VARS)
(FNS/VARS (LIST (FILECOMS ROOTNAME 'COMS)
(FILECOMS ROOTNAME 'BLOCKS)))
(LOADCOMP (* ;
 "evaluate the EVAL@COMPILE expresions, notice the fns and vars.")
(SETQ FNLST T)
VARS)
(FILEMAP (* ;
 "Return the filemap, or build one if not already available")
(if (AND FILEMAP (NULL (CAR FILEMAP)))
then (RETURN FILEMAP)
elseif (NULL BUILDMAPFLG)
then (RETURN NIL))
'FILEMAP)
(LOADFROM
(* ;; "evaluate all non-defineq expressions, but just return file name as value, i.e. dont bother adding to donelst")
[PROG ((*PACKAGE* *INTERLISP-PACKAGE*)
(DFNFLG DFNFLG)
(BUILDMAPFLG BUILDMAPFLG)
(FILEPKGFLG FILEPKGFLG)
(ADDSPELLFLG ADDSPELLFLG)
(LISPXHIST LISPXHIST)
(FILECREATEDLST)
(PRLST (AND FILEPKGFLG (FILEPKGCHANGES)))
INSTREAM FNLST VARLST DONELST ROOTNAME FILEMAP TEM FILEMAPEND FILECREATEDLOC FILENV
RESETSAVER MAPUPDATED)
(DECLARE (SPECVARS *PACKAGE* DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FNLST
VARLST DONELST FILECREATEDLST FILECREATEDLOC))
(* ;
 "FILECREATEDLST is set by SCANEXP when it encounters a FILECREATED expression")
TOP (COND
((OR (EQ LDFLG 'EXPRESSIONS)
(EQ LDFLG 'GETDEF)
(MEMB LDFLG LOADOPTIONS))
(SETQ DFNFLG LDFLG))
((AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T)))
(SETQ LDFLG TEM)
(SETQ DFNFLG LDFLG))
(T (SETQ LDFLG (ERROR "unrecognized load option" LDFLG))
(GO TOP)))
(COND
((EQ LDFLG 'SYSLOAD)
(SETQ DFNFLG T)
(SETQ ADDSPELLFLG NIL)
(SETQ BUILDMAPFLG NIL)
(SETQ FILEPKGFLG NIL)
(SETQ LISPXHIST NIL)))
[AND LISPXHIST (COND
((SETQ TEM (FMEMB 'SIDE LISPXHIST))
(FRPLACA (CADR TEM)
-1))
(T (LISPXPUT 'SIDE (LIST -1)
NIL LISPXHIST] (* ;
 "So that UNDOSAVE will keep saving regardless of how many undosaves are involved")
(SETQ FNLST (LOADFNS-MAKELIST FNS T)) (* ; "Get list of functions")
[COND
((NULL FILE) (* ;
 "Infer what file caller meant (this is a feature!)")
(SETQ FILE (LOADFNS-FINDFILE (CAR FNLST]
RETRY
[RESETSAVE NIL (SETQ RESETSAVER (LIST 'CLOSEF? (SETQ INSTREAM (OPENSTREAM FILE
'INPUT]
(* ;
 "CLOSEF? not CLOSEF because UPDATEFILEMAP might close file for us")
(RESETSAVE (INPUT INSTREAM))
(SETQ FILE (FULLNAME INSTREAM)) (* ;
 "Gets full file name. Also note that there may have been some error correction done in OPENSTREAM")
(COND
((NOT (RANDACCESSP INSTREAM))
(SETQ FILE (ERROR FILE "not a random access file"))
(GO RETRY)))
(SETFILEPTR INSTREAM 0)
(SETQ ROOTNAME (ROOTFILENAME FILE))
(CL:MULTIPLE-VALUE-SETQ (FILENV FILEMAP FILECREATEDLOC FILECREATEDLST)
(GET-ENVIRONMENT-AND-FILEMAP INSTREAM))
(\EXTERNALFORMAT INSTREAM FILENV)
(SETQ VARLST (SELECTQ VARS
(NIL NIL)
(VARS (* ;
 "Means load, i.e., evaluate, ALL rpaq/rpaqq")
'VARS)
(FNS/VARS (LIST (FILECOMS ROOTNAME 'COMS)
(FILECOMS ROOTNAME 'BLOCKS)))
(LOADCOMP (* ;
 "evaluate the EVAL@COMPILE expresions, notice the fns and vars.")
(SETQ FNLST T)
VARS)
(FILEMAP (* ;
 "Return the filemap, or build one if not already available")
(if (AND FILEMAP (NULL (CAR FILEMAP)))
then (RETURN FILEMAP)
elseif (NULL BUILDMAPFLG)
then (RETURN NIL))
'FILEMAP)
(LOADFROM
(* ;; "evaluate all non-defineq expressions, but just return file name as value, i.e. dont bother adding to donelst")
'LOADFROM)
(DONTCOPY (* ;
 "means load all DECLARE: DONTCOPY expressions")
VARS)
(LOADFNS-MAKELIST VARS)))
(SETQ FILEMAPEND (if FILEMAP
then (CAR FILEMAP)
else T)) (* ;
 "Remember how far the filemap scan got already")
[WITH-READER-ENVIRONMENT
FILENV
(SETQ FILEMAP (LOADFNSCAN FILEMAP))
'LOADFROM)
(DONTCOPY (* ;
 "means load all DECLARE: DONTCOPY expressions")
VARS)
(LOADFNS-MAKELIST VARS)))
(SETQ FILEMAPEND (if FILEMAP
then (CAR FILEMAP)
else T)) (* ;
 "Remember how far the filemap scan got already")
(WITH-READER-ENVIRONMENT FILENV
(SETQ FILEMAP (LOADFNSCAN FILEMAP))
(* ;;; "SCANFILE0 returns a 'map' for the file. The form of the map is (ADR ADRLST ADRLST ...) where ADR is last address scanned to in file, or NIL if entire file was scanned, or (ADR) where the scan stopped after a function in the middle of a DEFINEQ. Each ADRLST is either of the form (ADR1 ADR2 . FN) or (ADR1 ADR2 (FN ADRX . ADRY) (FN ADRX . ADRY) ...).
(* ;;; "SCANFILE0 returns a 'map' for the file. The form of the map is (ADR ADRLST ADRLST ...) where ADR is last address scanned to in file, or NIL if entire file was scanned, or (ADR) where the scan stopped after a function in the middle of a DEFINEQ. Each ADRLST is either of the form (ADR1 ADR2 . FN) or (ADR1 ADR2 (FN ADRX . ADRY) (FN ADRX . ADRY) ...).
The first case corresponds to a compiled function, the second to a DEFINEQ. In the first case, ADR1 is the address of the first character AFTER the function name in the file (for use by LAPRD) and ADR2 the address of the first character after the de definition, i.e., after LAPRD or LCSKIP has finished.
@@ -218,89 +212,89 @@ In the second case, ADR1 is the address of the lef paren before the DEFINEQ, and
A map of non-functions is not kept because (a) it would not be of use to MAKEFILE since it always recomputes VARS, and (B) most requests for other than functions require scanning the entire file anyway, e.g. to find all RPAQQ's, and (C) the expressions are usually small compared to DEFINEQ's.")
[if FILEMAP
then
(if (NEQ FILEMAPEND (CAR FILEMAP))
then (* ; "something was added")
(PUTFILEMAP FILE FILEMAP FILECREATEDLST)
(if (AND UPDATEMAPFLG (UPDATEFILEMAP INSTREAM FILEMAP))
then (SETQ MAPUPDATED T)))
(if (AND DWIMFLG (NOT NOSPELLFLG)
(LISTP FNLST))
then (* ;
 "There are still FNS left that we didn't find")
(if (SETQ TEM
(for X on FNLST
bind [KNOWNFNS _ (for TRIPLE in (CDR FILEMAP)
join (* ;
 "makes a list of functions found for use for spelling correction.")
(if (LISTP (SETQ TEM (CDDR TRIPLE)))
then
(* ;
 "This is for normal source files, where TRIPLE = (start end . fnEntries)")
(MAPCAR TEM (FUNCTION CAR))
elseif TEM
then
(* ;
 "For compiled files, TRIPLE = (start end . fn)")
(LIST TEM]
when (AND (NOT (FMEMB (CAR X)
KNOWNFNS))
(FIXSPELL (CAR X)
70 KNOWNFNS NIL X)) collect
(* ;; "The FMEMB check is necessary for when VARS=DEFS, as the reason that the function was not removed from FNLST may have been because this was a compiled file.")
[if FILEMAP
then
(if (NEQ FILEMAPEND (CAR FILEMAP))
then (* ; "something was added")
(PUTFILEMAP FILE FILEMAP FILECREATEDLST)
(if (AND UPDATEMAPFLG (UPDATEFILEMAP INSTREAM FILEMAP))
then (SETQ MAPUPDATED T)))
(if (AND DWIMFLG (NOT NOSPELLFLG)
(LISTP FNLST))
then (* ;
 "There are still FNS left that we didn't find")
(if
(SETQ TEM
(for X on FNLST
bind [KNOWNFNS _
(for TRIPLE in (CDR FILEMAP)
join (* ;
 "makes a list of functions found for use for spelling correction.")
(if (LISTP (SETQ TEM (CDDR TRIPLE)))
then (* ;
 "This is for normal source files, where TRIPLE = (start end . fnEntries)")
(MAPCAR TEM (FUNCTION CAR))
elseif TEM
then (* ;
 "For compiled files, TRIPLE = (start end . fn)")
(LIST TEM]
when (AND (NOT (FMEMB (CAR X)
KNOWNFNS))
(FIXSPELL (CAR X)
70 KNOWNFNS NIL X)) collect
(CAR X)))
then (if MAPUPDATED
then (* ; "UPDATEFILEMAP had closed the file")
[RPLACA (CDR RESETSAVER)
(SETQ INSTREAM (OPENSTREAM FILE 'INPUT]
(INPUT INSTREAM))
(SCANFILE1 FILEMAP TEM]
(if (AND NOT-FOUNDTAG (LISTP FNLST))
then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG FNLST)
DONELST)))
(if
[AND
NOT-FOUNDTAG
(LISTP VARLST)
(SETQ TEM
(if (FNTYP VARLST)
then (AND (NULL DONELST)
(LIST VARLST))
else (for X in VARLST collect X
unless (PROGN
(* ;; "Reason for this is if user says LOADVARS (DEFLIST file), then DEFLIST is not removed from VARLST, since you want all such instances.")
(* ;; "The FMEMB check is necessary for when VARS=DEFS, as the reason that the function was not removed from FNLST may have been because this was a compiled file.")
(for Y in DONELST
thereis (if (ATOM X)
then (OR (EQ X (CAR Y))
(EQ X (CADR Y)))
else (EDIT4E X Y]
then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG TEM)
DONELST)))
(if (EQ LDFLG 'SYSLOAD)
then (AND (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR FILECREATEDLST)))
SYSFILES))
(SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
(SMASHFILECOMS ROOTNAME)
elseif FILEPKGFLG
then (AND (NEQ VARS 'FILEMAP)
(NEQ LDFLG 'EXPRESSIONS)
(NEQ LDFLG 'GETDEF)
(ADDFILE FILE (SELECTQ VARS
((T LOADFROM)
'LOADFNS)
(LOADCOMP 'LOADCOMP)
'loadfns)
PRLST FILECREATEDLST]
(RETURN (if (EQ VARS 'FILEMAP)
then FILEMAP
elseif (EQ VARS 'LOADFROM)
then FILE
else (DREVERSE DONELST])
(CAR X)))
then (if MAPUPDATED
then (* ; "UPDATEFILEMAP had closed the file")
[RPLACA (CDR RESETSAVER)
(SETQ INSTREAM (OPENSTREAM FILE 'INPUT]
(INPUT INSTREAM))
(SCANFILE1 FILEMAP TEM]
(if (AND NOT-FOUNDTAG (LISTP FNLST))
then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG FNLST)
DONELST)))
(if
[AND
NOT-FOUNDTAG
(LISTP VARLST)
(SETQ TEM
(if (FNTYP VARLST)
then (AND (NULL DONELST)
(LIST VARLST))
else (for X in VARLST collect X
unless (PROGN
(* ;; "Reason for this is if user says LOADVARS (DEFLIST file), then DEFLIST is not removed from VARLST, since you want all such instances.")
(for Y in DONELST
thereis (if (ATOM X)
then (OR (EQ X (CAR Y))
(EQ X (CADR Y)))
else (EDIT4E X Y]
then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG TEM)
DONELST)))
(if (EQ LDFLG 'SYSLOAD)
then (AND (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR FILECREATEDLST)))
SYSFILES))
(SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
(SMASHFILECOMS ROOTNAME)
elseif FILEPKGFLG
then (AND (NEQ VARS 'FILEMAP)
(NEQ LDFLG 'EXPRESSIONS)
(NEQ LDFLG 'GETDEF)
(ADDFILE FILE (SELECTQ VARS
((T LOADFROM)
'LOADFNS)
(LOADCOMP 'LOADCOMP)
'loadfns)
PRLST FILECREATEDLST))))
(RETURN (if (EQ VARS 'FILEMAP)
then FILEMAP
elseif (EQ VARS 'LOADFROM)
then FILE
else (DREVERSE DONELST])])
(LOADFNS-FINDFILE
[LAMBDA (FN) (* bvm%: "27-Sep-86 15:03")
@@ -883,13 +877,12 @@ A map of non-functions is not kept because (a) it would not be of use to MAKEFIL
(SPECVARS VARLST)
(RETFNS SCANFILE0))
)
(PUTPROPS LOADFNS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1986 1987 1989 1990 2018 2022))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1224 19374 (LOADFROM 1234 . 1707) (LOADBLOCK 1709 . 2217) (GETBLOCKDEC 2219 . 3084) (
LOADCOMP 3086 . 4249) (LOADCOMP? 4251 . 4951) (LOADVARS 4953 . 5033) (LOADEFS 5035 . 5179) (
LOADFILEMAP 5181 . 5585) (LOADFNS 5587 . 17659) (LOADFNS-FINDFILE 17661 . 18177) (LOADFNS-MAKELIST
18179 . 19372)) (19375 46586 (LOADFNSCAN 19385 . 19563) (SCANFILE0 19565 . 22972) (SCANCOMPILEDFN
22974 . 25276) (SCANDEFINEQ 25278 . 30576) (SCANEXP 30578 . 35329) (SCANDECLARECOLON 35331 . 39535) (
SCANFILE1 39537 . 43619) (SCANFILE2 43621 . 43907) (TMPSUBFN 43909 . 45073) (RETRYSCAN 45075 . 45472)
(SCANFILEHELP 45474 . 46584)))))
(FILEMAP (NIL (1109 19777 (LOADFROM 1119 . 1592) (LOADBLOCK 1594 . 2102) (GETBLOCKDEC 2104 . 2969) (
LOADCOMP 2971 . 4134) (LOADCOMP? 4136 . 4836) (LOADVARS 4838 . 4918) (LOADFILEMAP 4920 . 5324) (
LOADFNS 5326 . 18062) (LOADFNS-FINDFILE 18064 . 18580) (LOADFNS-MAKELIST 18582 . 19775)) (19778 46989
(LOADFNSCAN 19788 . 19966) (SCANFILE0 19968 . 23375) (SCANCOMPILEDFN 23377 . 25679) (SCANDEFINEQ 25681
. 30979) (SCANEXP 30981 . 35732) (SCANDECLARECOLON 35734 . 39938) (SCANFILE1 39940 . 44022) (
SCANFILE2 44024 . 44310) (TMPSUBFN 44312 . 45476) (RETRYSCAN 45478 . 45875) (SCANFILEHELP 45877 .
46987)))))
STOP

BIN
sources/LOADFNS.LCOM
View File

Binary file not shown.

376
sources/MACHINEINDEPENDENT
View File

@@ -1,14 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Sep-2025 12:51:06" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;39 119579
(FILECREATED "22-Feb-2026 13:55:06" {WMEDLEY}<sources>MACHINEINDEPENDENT.;40 125302
:EDIT-BY rmk
:CHANGES-TO (VARS MACHINEINDEPENDENTCOMS)
:PREVIOUS-DATE "18-Jan-2024 10:40:56"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;38)
:PREVIOUS-DATE "29-Sep-2025 12:51:06" {WMEDLEY}<sources>MACHINEINDEPENDENT.;39)
(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS)
@@ -19,9 +17,6 @@
(INITVARS (*COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT]
(COMS (* ;
 "random machine-independent utilities")
(FNS DMPHASH HASHOVERFLOW)
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST
HASHOVERFLOW.UPDATEARRAY))
(FNS BKBUFS CHANGENAME CHNGNM CLBUFS DEFINE FNS.PUTDEF EQMEMB EQUALN FNCHECK FNTYP1
LCSKIP MAPRINT MKLIST NAMEFIELD NLIST PRINTBELLS PROMPTCHAR RAISEP READFILE
READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 WRITEFILE CLOSE-AND-MAYBE-DELETE
@@ -485,104 +480,6 @@
(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
(BKBUFS
[LAMBDA (BUFS ID) (* DD%: " 6-Oct-81 15:34")
(PROG (L S)
@@ -2494,24 +2391,255 @@ This has little hope of working any more.")
(LOCALVARS . T)
)
(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS)
(RPAQQ MACHINEINDEPENDENTCOMS
([COMS (* ; " %"File loader%"")
(FNS LOAD? FILESLOAD DOFILESLOAD FINDFILE-WITH-EXTENSIONS READ-FILECREATED)
(INITVARS (*COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT]
(COMS (* ;
 "random machine-independent utilities")
(FNS BKBUFS CHANGENAME CHNGNM CLBUFS DEFINE FNS.PUTDEF EQMEMB EQUALN FNCHECK FNTYP1
LCSKIP MAPRINT MKLIST NAMEFIELD NLIST PRINTBELLS PROMPTCHAR RAISEP READFILE
READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 WRITEFILE CLOSE-AND-MAYBE-DELETE
UNSAFE.TO.MODIFY)
(VARS UNSAFE.TO.MODIFY.FNS)
(INITVARS (OK.TO.MODIFY.FNS))
[COMS (* ;
 "FILEDATE, for finding out the creation date of source files, from the compiled files.")
(FNS FILEDATE COMPILEFILETYPE)
(* ;; "FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now. It's defined in FASLOAD.")
(P (MOVD? 'NILL 'FASL-FILEDATE]
(P (MOVD? 'CL:FMAKUNBOUND 'UNDOABLY-FMAKUNBOUND))
(* ;
 "used in FNS.PUTDEF before CMLUNDO loaded")
)
(COMS (* ;
 "Functions for retrieving and remembering FILEMAPs and file reader environments")
(FNS FILEMAP \PARSE-FILE-HEADER GET-ENVIRONMENT-AND-FILEMAP
LOOKUP-ENVIRONMENT-AND-FILEMAP GET-FILEMAP-FROM-FILECREATED \FILEMAP-HASHOVERFLOW
FLUSHFILEMAPS LISPSOURCEFILEP LISPFILETYPE GETFILEMAP PUTFILEMAP UPDATEFILEMAP)
[INITVARS (*FILEMAP-LIMIT* 20)
(*FILEMAP-VERSIONS* 2)
(*FILEMAP-HASH* (HASHARRAY *FILEMAP-LIMIT* (FUNCTION \FILEMAP-HASHOVERFLOW)
(FUNCTION STRING-EQUAL-HASHBITS)
(FUNCTION STRING.EQUAL]
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FILEMAPHASH)
(GLOBALVARS *FILEMAP-LIMIT* *FILEMAP-VERSIONS* *FILEMAP-HASH*)))
(COMS (* * LVLPRINT)
(FNS LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0))
(COMS (* ; "used by PRINTOUT")
(FNS FLUSHRIGHT PRINTPARA PRINTPARA1))
(COMS (* ; "SUBLIS and friends")
(FNS SUBLIS SUBPAIR DSUBLIS))
[COMS (* * CONSTANTS)
(FNS CONSTANTOK)
(P (MOVD? 'EVQ 'CONSTANT)
(MOVD? 'EVQ 'DEFERREDCONSTANT)
(MOVD? 'EVQ 'LOADTIMECONSTANT]
(COMS (* * SCRATCHLIST)
(PROP MACRO SCRATCHLIST ADDTOSCRATCHLIST)
(PROP INFO SCRATCHLIST))
(GLOBALVARS SYSFILES LOADOPTIONS LISPXCOMS CLISPTRANFLG COMMENTFLG HISTSTR4 LISPXREADFN
REREADFLG HISTSTR0 CTRLUFLG NOLINKMESS PROMPTCHARFORMS PROMPT#FLG FILERDTBL SPELLINGS2
USERWORDS BELLS CLISPARRAY)
(FNS NLAMBDA.ARGS)
[DECLARE%:
DONTEVAL@LOAD DOCOPY (* ;
 "initialization of variables used in many places")
(ADDVARS (CLISPARRAY)
(CLISPFLG)
(CTRLUFLG)
(EDITCALLS)
(EDITHISTORY)
(EDITUNDOSAVES)
(EDITUNDOSTATS)
(GLOBALVARS)
(LCASEFLG)
(LISPXBUFS)
(LISPXCOMS)
(LISPXFNS)
(LISPXHIST)
(LISPXHISTORY)
(LISPXPRINTFLG)
(NOCLEARSTKLST)
(NOFIXFNSLST)
(NOFIXVARSLST)
(P.A.STATS)
(PROMPTCHARFORMS)
(READBUF)
(READBUFSOURCE)
(REREADFLG)
(RESETSTATE)
(SPELLSTATS1))
(INITVARS (CHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL NIL))
(CHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL))
(CHCONLST2 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL))
(CLEARSTKLST T)
(CLISPTRANFLG 'CLISP% )
(HISTSTR0 "<c.r.>")
(HISTSTR2 "repeat")
(HISTSTR3 "from event:")
(HISTSTR4 "ignore")
(LISPXREADFN 'READ)
(USEMAPFLG T))
(P [MAPC '((APPLY BLKAPPLY)
(SETTOPVAL SETATOMVAL)
(GETTOPVAL GETATOMVAL)
(APPLY* BLKAPPLY*)
(RPLACA FRPLACA)
(RPLACD FRPLACD)
(STKNTH FSTKNTH)
(STKNAME FSTKNAME)
(CHARACTER FCHARACTER)
(STKARG FSTKARG)
(CHCON DCHCON)
(UNPACK DUNPACK)
(ADDPROP /ADDPROP)
(ATTACH /ATTACH)
(DREMOVE /DREMOVE)
(DSUBST /DSUBST)
(NCONC /NCONC)
(NCONC1 /NCONC1)
(PUT /PUT)
(PUTPROP /PUTPROP)
(PUTD /PUTD)
(REMPROP /REMPROP)
(RPLACA /RPLACA)
(RPLACD /RPLACD)
(SET /SET)
(SETATOMVAL /SETATOMVAL)
(SETTOPVAL /SETTOPVAL)
(SETPROPLIST /SETPROPLIST)
(SET SAVESET)
(PRINT LISPXPRINT)
(PRIN1 LISPXPRIN1)
(PRIN2 LISPXPRIN2)
(SPACES LISPXSPACES)
(TAB LISPXTAB)
(TERPRI LISPXTERPRI)
(PRINT SHOWPRINT)
(PRIN2 SHOWPRIN2)
(PUTHASH /PUTHASH)
'*
(FNCLOSER /FNCLOSER)
(FNCLOSERA /FNCLOSERA)
(FNCLOSERD /FNCLOSERD)
(EVQ DELFILE)
(NILL SMASHFILECOMS)
(PUTASSOC /PUTASSOC)
(LISTPUT1 PUTL)
(NILL I.S.OPR)
(NILL RESETUNDO)
(NILL LISPXWATCH)
'ADDSTATS
(NILL FREEVARS)
'USEDFREE
(COPYBYTES COPYCHARS))
(FUNCTION (LAMBDA (X)
(MOVD? (CAR X)
(CADR X]
[MAPC '((TIME PRIN1 LISPXPRIN1)
(TIME SPACES LISPXSPACES)
(TIME PRINT LISPXPRINT)
(DEFC PRINT LISPXPRINT)
(DEFC PUTD /PUTD)
(DEFC PUTPROP /PUTPROP)
(DOLINK FNCLOSERD /FNCLOSERD)
(DOLINK FNCLOSERA /FNCLOSERA)
(DEFLIST PUTPROP /PUTPROP)
(SAVEDEF1 PUTPROP /PUTPROP)
(MKSWAPBLOCK PUTD /PUTD))
(FUNCTION (LAMBDA (X)
(AND (CCODEP (CAR X))
(APPLY 'CHANGENAME X]
(MAPC '[[EVALQT (LAMBDA NIL (PROG (TEM)
(RESETRESTORE NIL 'RESET)
LP
(PROMPTCHAR '_ T)
(LISPX (LISPXREAD T T))
(GO LP]
[LISPX (LAMBDA (LISPXX)
(PRINT [AND LISPXX (PROG (LISPXLINE LISPXHIST TEM)
(RETURN (COND ((AND (NLISTP LISPXX)
(SETQ LISPXLINE
(READLINE T NIL
T)))
(APPLY LISPXX (CAR
LISPXLINE
)))
(T (EVAL LISPXX]
T T]
[LISPXREAD (LAMBDA (FILE RDTBL)
(COND [READBUF (PROG1 (CAR READBUF)
(SETQ READBUF (CDR READBUF)))]
(T (READ FILE RDTBL]
[LISPXREADP (LAMBDA (FLG)
(COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF)))
T)
(T (READP T FLG]
[LISPXUNREAD (LAMBDA (LST)
(SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF]
[LISPXREADBUF (LAMBDA (RDBUF)
(PROG NIL LP (COND ((NLISTP RDBUF)
(RETURN NIL))
((EQ (CAR RDBUF)
HISTSTR0)
(SETQ RDBUF (CDR RDBUF))
(GO LP))
(T (RETURN RDBUF]
[LISPX/ (LAMBDA (X)
X]
[LOWERCASE (LAMBDA (FLG)
(PROG1 LCASEFLG
(RAISE (NULL FLG))
(RPAQ LCASEFLG FLG))]
[FILEPOS (LAMBDA (STR FILE)
(PROG NIL LP (COND ((EQ (PEEKC FILE)
(NTHCHAR STR 1))
(RETURN T)))
(READC FILE)
(GO LP]
(FILEPKGCOM (NLAMBDA NIL NIL]
(FUNCTION (LAMBDA (L)
(OR (GETD (CAR L))
(PUTD (CAR L)
(CADR L]
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA RESETBUFS
FILESLOAD)
(NLAML FILEMAP)
(LAMA READFILE NLIST)))
(LOCALVARS . T)))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA RESETBUFS FILESLOAD)
(ADDTOVAR NLAML FILEMAP)
(ADDTOVAR LAMA READFILE NLIST)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (12643 26068 (LOAD? 12653 . 14504) (FILESLOAD 14506 . 14795) (DOFILESLOAD 14797 . 22423)
(FINDFILE-WITH-EXTENSIONS 22425 . 25624) (READ-FILECREATED 25626 . 26066)) (26185 31506 (DMPHASH
26195 . 27789) (HASHOVERFLOW 27791 . 31504)) (32262 64370 (BKBUFS 32272 . 33391) (CHANGENAME 33393 .
33654) (CHNGNM 33656 . 35504) (CLBUFS 35506 . 36779) (DEFINE 36781 . 37505) (FNS.PUTDEF 37507 . 40922)
(EQMEMB 40924 . 41106) (EQUALN 41108 . 41937) (FNCHECK 41939 . 43946) (FNTYP1 43948 . 44045) (LCSKIP
44047 . 44891) (MAPRINT 44893 . 45839) (MKLIST 45841 . 45991) (NAMEFIELD 45993 . 47518) (NLIST 47520
. 47855) (PRINTBELLS 47857 . 47983) (PROMPTCHAR 47985 . 49875) (RAISEP 49877 . 50138) (READFILE 50140
. 52484) (READLINE 52486 . 57926) (REMPROPLIST 57928 . 58816) (RESETBUFS 58818 . 59268) (TAB 59270 .
59866) (UNSAVED1 59868 . 60973) (WRITEFILE 60975 . 62717) (CLOSE-AND-MAYBE-DELETE 62719 . 63063) (
UNSAFE.TO.MODIFY 63065 . 64368)) (66589 71430 (FILEDATE 66599 . 69531) (COMPILEFILETYPE 69533 . 71428)
) (71796 98999 (FILEMAP 71806 . 72276) (\PARSE-FILE-HEADER 72278 . 76093) (GET-ENVIRONMENT-AND-FILEMAP
76095 . 78322) (LOOKUP-ENVIRONMENT-AND-FILEMAP 78324 . 80515) (GET-FILEMAP-FROM-FILECREATED 80517 .
81341) (\FILEMAP-HASHOVERFLOW 81343 . 86007) (FLUSHFILEMAPS 86009 . 86632) (LISPSOURCEFILEP 86634 .
88026) (LISPFILETYPE 88028 . 91277) (GETFILEMAP 91279 . 91698) (PUTFILEMAP 91700 . 93891) (
UPDATEFILEMAP 93893 . 98997)) (99665 103251 (LVLPRINT 99675 . 99848) (LVLPRIN1 99850 . 100032) (
LVLPRIN2 100034 . 100266) (LVLPRIN 100268 . 101282) (LVLPRIN0 101284 . 103249)) (103285 108202 (
FLUSHRIGHT 103295 . 104110) (PRINTPARA 104112 . 105210) (PRINTPARA1 105212 . 108200)) (108238 110523 (
SUBLIS 108248 . 108856) (SUBPAIR 108858 . 110086) (DSUBLIS 110088 . 110521)) (110546 111146 (
CONSTANTOK 110556 . 111144)) (112899 113604 (NLAMBDA.ARGS 112909 . 113602)))))
(FILEMAP (NIL (12360 25785 (LOAD? 12370 . 14221) (FILESLOAD 14223 . 14512) (DOFILESLOAD 14514 . 22140)
(FINDFILE-WITH-EXTENSIONS 22142 . 25341) (READ-FILECREATED 25343 . 25783)) (25902 58010 (BKBUFS 25912
. 27031) (CHANGENAME 27033 . 27294) (CHNGNM 27296 . 29144) (CLBUFS 29146 . 30419) (DEFINE 30421 .
31145) (FNS.PUTDEF 31147 . 34562) (EQMEMB 34564 . 34746) (EQUALN 34748 . 35577) (FNCHECK 35579 . 37586
) (FNTYP1 37588 . 37685) (LCSKIP 37687 . 38531) (MAPRINT 38533 . 39479) (MKLIST 39481 . 39631) (
NAMEFIELD 39633 . 41158) (NLIST 41160 . 41495) (PRINTBELLS 41497 . 41623) (PROMPTCHAR 41625 . 43515) (
RAISEP 43517 . 43778) (READFILE 43780 . 46124) (READLINE 46126 . 51566) (REMPROPLIST 51568 . 52456) (
RESETBUFS 52458 . 52908) (TAB 52910 . 53506) (UNSAVED1 53508 . 54613) (WRITEFILE 54615 . 56357) (
CLOSE-AND-MAYBE-DELETE 56359 . 56703) (UNSAFE.TO.MODIFY 56705 . 58008)) (60229 65070 (FILEDATE 60239
. 63171) (COMPILEFILETYPE 63173 . 65068)) (65436 92639 (FILEMAP 65446 . 65916) (\PARSE-FILE-HEADER
65918 . 69733) (GET-ENVIRONMENT-AND-FILEMAP 69735 . 71962) (LOOKUP-ENVIRONMENT-AND-FILEMAP 71964 .
74155) (GET-FILEMAP-FROM-FILECREATED 74157 . 74981) (\FILEMAP-HASHOVERFLOW 74983 . 79647) (
FLUSHFILEMAPS 79649 . 80272) (LISPSOURCEFILEP 80274 . 81666) (LISPFILETYPE 81668 . 84917) (GETFILEMAP
84919 . 85338) (PUTFILEMAP 85340 . 87531) (UPDATEFILEMAP 87533 . 92637)) (93305 96891 (LVLPRINT 93315
. 93488) (LVLPRIN1 93490 . 93672) (LVLPRIN2 93674 . 93906) (LVLPRIN 93908 . 94922) (LVLPRIN0 94924 .
96889)) (96925 101842 (FLUSHRIGHT 96935 . 97750) (PRINTPARA 97752 . 98850) (PRINTPARA1 98852 . 101840)
) (101878 104163 (SUBLIS 101888 . 102496) (SUBPAIR 102498 . 103726) (DSUBLIS 103728 . 104161)) (104186
104786 (CONSTANTOK 104196 . 104784)) (106539 107244 (NLAMBDA.ARGS 106549 . 107242)))))
STOP

BIN
sources/MACHINEINDEPENDENT.LCOM
View File

Binary file not shown.

296
sources/MCCS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)
(FILECREATED " 5-Feb-2026 15:58:32" {WMEDLEY}<sources>MCCS.;163 65441
(FILECREATED "26-Feb-2026 12:57:11" {WMEDLEY}<sources>MCCS.;168 61634
:EDIT-BY rmk
:CHANGES-TO (FNS \DUMMY-UTF8-FORMAT \CREATE.XCCS.EXTERNALFORMAT)
:CHANGES-TO (FNS MCCSMAPPAIRS)
:PREVIOUS-DATE " 5-Feb-2026 12:26:39" {WMEDLEY}<sources>MCCS.;161)
:PREVIOUS-DATE "20-Feb-2026 09:21:16" {WMEDLEY}<sources>MCCS.;167)
(PRETTYCOMPRINT MCCSCOMS)
@@ -57,14 +57,10 @@
 "Mappings into MCCS: needed for hardcopy and Tedit coercion, e.g. \TEDIT.MCCS.TRANSLATE")
(FNS GACHATOMCODE SYMBOLTOMCODE SIGMATOMCODE ATOMCODE MATHTOMCODE HIPPOTOMCODE
CYRILLICTOMCODE PALATINOTOMCODE)))
(COMS (* ; "ISO8859/1")
(FNS ISO1TOMCODE MTOISO1CODE \CREATE.ISO1.FORMAT \DUMMY-UTF8-FORMAT)
(FNS ISO1TOMSTRING MTOISO1STRING)
(VARS ISO1TOMCCS)
(GLOBALVARS ISO1TOMCCS)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.ISO1.FORMAT)
(\DUMMY-UTF8-FORMAT])
CYRILLICTOMCODE PALATINOTOMCODE))
(COMS (FNS SYSTEM-EXTERNALFORMAT MTOSYSSTRING SYSTOMSTRING)
(EXPORT (GLOBALVARS *SYSTEM-EXTERNALFORMAT*))
(INITVARS (*SYSTEM-EXTERNALFORMAT* :UTF-8])
@@ -427,7 +423,7 @@
(* ;; "Converts Unicodes to MCCS codes in XSTRING.")
(for I XCODE (MSTRING _ (CL:IF DESTRUCTIVE
(for I XCODE (MSTRING ← (CL:IF DESTRUCTIVE
XSTRING
(CONCAT XSTRING))) from 1 while (SETQ XCODE (NTHCHARCODE XSTRING I))
do (RPLCHARCODE MSTRING I (XTOMCODE XCODE)) finally (RETURN MSTRING])
@@ -438,7 +434,7 @@
(* ;; "Converts XCCS to MCCS codes in XSTRING.")
(for I MCODE (XSTRING _ (CL:IF DESTRUCTIVE
(for I MCODE (XSTRING ← (CL:IF DESTRUCTIVE
MSTRING
(CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I))
do (RPLCHARCODE XSTRING I (MTOXCODE MCODE)) finally (RETURN XSTRING])
@@ -500,12 +496,12 @@
(
(* ;; "From bravo doc")
(^N "356,055" MINUS)
(^V "357,44" ENDASH)
(^S EMDASH)
(^O EMQUAD)
(^X "356,055" MINUS)
(^Y FIGURESPACE ENQUAD)
(↑N "356,055" MINUS)
(↑V "357,44" ENDASH)
(↑S EMDASH)
(↑O EMQUAD)
(↑X "356,055" MINUS)
(↑Y FIGURESPACE ENQUAD)
(* ;; "Fom current Helvetica/Timesroman fonts")
@@ -1372,7 +1368,8 @@
NIL])
(MCCSMAPPAIRS
[LAMBDA (FROMENCODING NONIDENTITY) (* ; "Edited 7-Oct-2025 14:47 by rmk")
[LAMBDA (FROMENCODING NONIDENTITY) (* ; "Edited 26-Feb-2026 12:56 by rmk")
(* ; "Edited 7-Oct-2025 14:47 by rmk")
(* ; "Edited 6-Oct-2025 09:47 by rmk")
(* ; "Edited 20-Sep-2025 09:45 by rmk")
(* ; "Edited 6-Sep-2025 16:43 by rmk")
@@ -1380,27 +1377,30 @@
(* ;; "Returns the pairs for MOVEFONTCHARS to use to move charset-0 glyphs into their MCCS positions. For example, the Leftarrow and Lowline glyphs switch positions in an XCCS$ font. Returns NIL (= nothing to do) if there is no function.")
(LET ((FN (MCCSMAPFN FROMENCODING))
PAIRS KEEPCS0)
(CL:WHEN FN
[SETQ PAIRS (SELECTQ FROMENCODING
(GACHA (* ; "ctrl and upper are slugged")
[APPEND (XCCSUNDEFINEDPAIRS)
'(((Uparrow TERMINAL)
Circumflex)
(^X Lowline])
(ALTOTEXT (APPEND (XCCSUNDEFINEDPAIRS)
ALTOTEXT2MCCS))
(XCCS$ '((Uparrow Circumflex)
(Leftarrow Lowline)
(Lowline Leftarrow)
(Circumflex Uparrow)))
(PALATINO (APPEND (XCCS.CS0.UNDEFINED)
PALATINOTOMCCS))
(PROGN (SETQ KEEPCS0 T)
(for C M from 0 to \MAXTHINCHAR
when (SETQ M (APPLY* FN C NONIDENTITY))
collect (LIST C M]
(LET (PAIRS KEEPCS0)
[SETQ PAIRS (SELECTQ FROMENCODING
(GACHA (* ; "ctrl and upper are slugged")
[APPEND (XCCSUNDEFINEDPAIRS)
'(((Uparrow TERMINAL)
Circumflex)
(↑X Lowline])
(ALTOTEXT (APPEND (XCCSUNDEFINEDPAIRS)
ALTOTEXT2MCCS))
(XCCS$ '((Uparrow Circumflex)
(Leftarrow Lowline)
(Lowline Leftarrow)
(Circumflex Uparrow)))
(UNICODE *UNICODETOMCCS*)
(PALATINO (APPEND (XCCS.CS0.UNDEFINED)
PALATINOTOMCCS))
(PROGN (SETQ KEEPCS0 T)
(for C M FN from 0 to \MAXTHINCHAR first (CL:UNLESS (SETQ FN
(MCCSMAPFN
FROMENCODING))
(RETURN))
when (SETQ M (APPLY* FN C NONIDENTITY))
collect (LIST C M]
(CL:WHEN (LISTP PAIRS)
(* ;; "Weed out interspersed comments, convert to charcodes")
@@ -1423,14 +1423,16 @@
(* ;; "Any character that is moved gets replaced by a slug. It may then be coerced from another font. But families like SYMBOL, HIPPO etc. want to preserve CS0 even if they copy their glyphs also to somewhere else.")
[APPEND PAIRS (for P in PAIRS when (CAR P)
unless [OR (AND KEEPCS0 (ILEQ (CAR P)
\MAXTHINCHAR))
(AND (LISTP (CAR P))
(LITATOM (CADAR P)))
(thereis X in PAIRS suchthat (EQ (CADR X)
(CAR P]
collect (LIST NIL (CAR P])])
[SETQ PAIRS (APPEND PAIRS (for P in PAIRS when (CAR P)
unless [OR (AND KEEPCS0 (ILEQ (CAR P)
\MAXTHINCHAR))
(AND (LISTP (CAR P))
(LITATOM (CADAR P)))
(thereis X in PAIRS
suchthat (EQ (CADR X)
(CAR P]
collect (LIST NIL (CAR P])
PAIRS])
(XCCS.CS0.UNDEFINED
[LAMBDA NIL (* ; "Edited 5-Oct-2025 22:44 by rmk")
@@ -1463,7 +1465,7 @@
(* ;; "Gacha did not have a code for circumflex, so there is nothing to map")
(CL:IF (EQ GCODE (CHARCODE ^X))
(CL:IF (EQ GCODE (CHARCODE ↑X))
(CHARCODE Lowline)
GCODE)])
@@ -1541,178 +1543,52 @@
MCODE)))
PCODE])
)
(* ; "ISO8859/1")
(DEFINEQ
(ISO1TOMCODE
[LAMBDA (ICODE) (* ; "Edited 5-Feb-2026 12:09 by rmk")
(* ; "Edited 2-Feb-2026 23:14 by rmk")
(* ; "Edited 7-Sep-2025 22:39 by rmk")
(* ; "Edited 3-Sep-2025 10:21 by rmk")
(* ; "Edited 7-Aug-2025 09:37 by rmk")
(SYSTEM-EXTERNALFORMAT
[LAMBDA NIL (* ; "Edited 6-Feb-2026 11:29 by rmk")
(* ; "Edited 31-Jan-2026 18:51 by rmk")
(* ; "Edited 10-Oct-2022 11:55 by lmm")
(* ; "Edited 7-Jul-2022 10:41 by rmk")
(* ;; "ISO codes are 8bit, MCODES maybe not. Caller shouldn't pass a fat code.")
(* ;; "Returns the name, sets the global. For now, UTF-8 or through, could be something else.")
(OR [CAR (find PAIR in ISO1TOMCCS suchthat (EQ ICODE (CADR PAIR]
ICODE])
(fetch (EXTERNALFORMAT NAME) of (SETQ *SYSTEM-EXTERNALFORMAT*
(FIND-FORMAT (FOR X IN '("LC_CTYPE" "LC_ALL" "LANG")
WHEN (STRPOS ".UTF-8" (UNIX-GETENV X))
DO (RETURN :UTF-8) FINALLY (RETURN :THROUGH])
(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])
(MTOSYSSTRING
[LAMBDA (MSTRING) (* ; "Edited 6-Feb-2026 00:20 by rmk")
(MCCSTOFORMATBYTES *SYSTEM-EXTERNALFORMAT* (MKSTRING MSTRING])
(\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])
(SYSTOMSTRING
[LAMBDA (SYSTRING) (* ; "Edited 5-Feb-2026 23:36 by rmk")
(\DUMMY-UTF8-FORMAT
[LAMBDA NIL (* ; "Edited 5-Feb-2026 15:58 by rmk")
(* ; "Edited 1-Feb-2026 13:16 by rmk")
(* ;; "SYSSTRING is presumably shared with Unix, guarantee a copy on the way out")
(* ;; "Works only for 7-bit codes, during the loadup")
(\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT using (FIND-FORMAT :ISO8859/1)
NAME _ :UTF-8])
(CONCAT (FORMATBYTESTOMCCS *SYSTEM-EXTERNALFORMAT* SYSTRING])
)
(DEFINEQ
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
(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])
(GLOBALVARS *SYSTEM-EXTERNALFORMAT*)
)
(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
(* "END EXPORTED DEFINITIONS")
(GLOBALVARS ISO1TOMCCS)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(\CREATE.ISO1.FORMAT)
(\DUMMY-UTF8-FORMAT)
)
(RPAQ? *SYSTEM-EXTERNALFORMAT* :UTF-8)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3345 14916 (\MCCSINCCODE 3355 . 6443) (\MCCSPEEKCCODE 6445 . 9332) (\MCCSOUTCHAR 9334
. 11433) (\MCCSBACKCCODE 11435 . 12979) (\MCCSFORMATBYTESTREAM 12981 . 13711) (\MCCSCHARSETFN 13713
. 14914)) (14917 17368 (\CREATE.MCCS.EXTERNALFORMAT 14927 . 15797) (\CREATE.XCCS.EXTERNALFORMAT 15799
. 17366)) (17369 18346 (\MCCS.24BITENCODING.ERROR 17379 . 18344)) (19722 22360 (MTOXCODE 19732 .
20529) (XTOMCODE 20531 . 21188) (XTOMSTRING 21190 . 21775) (MTOXSTRING 21777 . 22358)) (22361 24021 (
MTOX$CODE 22371 . 23103) (X$TOMCODE 23105 . 24019)) (24022 24662 (KANJICHARSETP 24032 . 24288) (
CHINESECHARSETP 24290 . 24660)) (45230 47719 (MCCSCODEMAPARRAY 45240 . 47717)) (48335 54816 (MCCSMAPFN
48345 . 49712) (MCCSMAPPAIRS 49714 . 53822) (XCCS.CS0.UNDEFINED 53824 . 54453) (XCCSUNDEFINEDPAIRS
54455 . 54814)) (54921 59673 (GACHATOMCODE 54931 . 55443) (SYMBOLTOMCODE 55445 . 56093) (SIGMATOMCODE
56095 . 56741) (ATOMCODE 56743 . 57275) (MATHTOMCODE 57277 . 57933) (HIPPOTOMCODE 57935 . 58472) (
CYRILLICTOMCODE 58474 . 58908) (PALATINOTOMCODE 58910 . 59671)) (59700 62493 (ISO1TOMCODE 59710 .
60459) (MTOISO1CODE 60461 . 60751) (\CREATE.ISO1.FORMAT 60753 . 62018) (\DUMMY-UTF8-FORMAT 62020 .
62491)) (62494 64025 (ISO1TOMSTRING 62504 . 63320) (MTOISO1STRING 63322 . 64023)))))
(FILEMAP (NIL (3103 14674 (\MCCSINCCODE 3113 . 6201) (\MCCSPEEKCCODE 6203 . 9090) (\MCCSOUTCHAR 9092
. 11191) (\MCCSBACKCCODE 11193 . 12737) (\MCCSFORMATBYTESTREAM 12739 . 13469) (\MCCSCHARSETFN 13471
. 14672)) (14675 17126 (\CREATE.MCCS.EXTERNALFORMAT 14685 . 15555) (\CREATE.XCCS.EXTERNALFORMAT 15557
. 17124)) (17127 18104 (\MCCS.24BITENCODING.ERROR 17137 . 18102)) (19480 22122 (MTOXCODE 19490 .
20287) (XTOMCODE 20289 . 20946) (XTOMSTRING 20948 . 21535) (MTOXSTRING 21537 . 22120)) (22123 23783 (
MTOX$CODE 22133 . 22865) (X$TOMCODE 22867 . 23781)) (23784 24424 (KANJICHARSETP 23794 . 24050) (
CHINESECHARSETP 24052 . 24422)) (45004 47493 (MCCSCODEMAPARRAY 45014 . 47491)) (48109 55125 (MCCSMAPFN
48119 . 49486) (MCCSMAPPAIRS 49488 . 54131) (XCCS.CS0.UNDEFINED 54133 . 54762) (XCCSUNDEFINEDPAIRS
54764 . 55123)) (55230 59984 (GACHATOMCODE 55240 . 55754) (SYMBOLTOMCODE 55756 . 56404) (SIGMATOMCODE
56406 . 57052) (ATOMCODE 57054 . 57586) (MATHTOMCODE 57588 . 58244) (HIPPOTOMCODE 58246 . 58783) (
CYRILLICTOMCODE 58785 . 59219) (PALATINOTOMCODE 59221 . 59982)) (59985 61423 (SYSTEM-EXTERNALFORMAT
59995 . 60939) (MTOSYSSTRING 60941 . 61134) (SYSTOMSTRING 61136 . 61421)))))
STOP

BIN
sources/MCCS.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.

392
sources/XCLC-TOP-LEVEL
View File

@@ -1,20 +1,19 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
(IL:FILECREATED "19-Sep-2020 22:02:59" 
IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;10| 78326
(DEFINE-FILE-INFO :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")) :READTABLE "XCL" :BASE 10)
IL:|changes| IL:|to:| (IL:FUNCTIONS START-COMPILATION)
(IL:FILECREATED "25-Feb-2026 23:03:55" IL:|{WMEDLEY}<sources>XCLC-TOP-LEVEL.;2| 78162
IL:|previous| IL:|date:| "19-Sep-2020 21:33:34"
IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
:EDIT-BY IL:|rmk|
:CHANGES-TO (IL:FUNCTIONS COMPILE-FILE)
:PREVIOUS-DATE "19-Sep-2020 22:02:59" IL:|{WMEDLEY}<sources>XCLC-TOP-LEVEL.;1|)
; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1994, 2020 by Venue & Xerox Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:XCLC-TOP-LEVELCOMS)
(IL:RPAQQ IL:XCLC-TOP-LEVELCOMS
(
(IL:* IL:|;;| "Top-level entry points ")
(IL:* IL:|;;| "Top-level entry points ")
(IL:STRUCTURES COMPILER-CONTEXT)
(IL:VARIABLES *COMPILE-FILE-CONTEXT* *COMPILE-SCAN-CONTEXT* *COMPILE-DEFINER-CONTEXT*)
@@ -33,18 +32,18 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(IL:COMS (IL:STRUCTURES ASSEMBLER-ERROR)
(IL:FUNCTIONS ASSEMBLER-ERROR))
(IL:* IL:|;;| "Reading the #, macro")
(IL:* IL:|;;| "Reading the #, macro")
(IL:VARIABLES *COMPILER-IS-READING*)
(IL:STRUCTURES EVAL-WHEN-LOAD)
(IL:* IL:|;;| "Support for Block Compilation")
(IL:* IL:|;;| "Support for Block Compilation")
(IL:VARIABLES *BLOCK-HASH-TABLE* *BLOCKS* *CURRENT-BLOCK*)
(IL:STRUCTURES BLOCK-DECL)
(IL:FUNCTIONS SET-UP-BLOCK-DECLS)
(IL:* IL:|;;| "Processing of top-level forms in a file")
(IL:* IL:|;;| "Processing of top-level forms in a file")
(IL:VARIABLES PASS)
(IL:FUNCTIONS CONSTANT-EXPRESSION-P)
@@ -60,14 +59,14 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
COMPILE-FILE-PROCESS-FUNCTION)
(IL:FUNCTIONS CRACK-DEFMACRO ESTABLISH-MACRO-IN-COMPILER)
(IL:* IL:|;;| "Support for :Process-Entire-File")
(IL:* IL:|;;| "Support for :Process-Entire-File")
(IL:VARIABLES *DEFERRED-FORMS* *MAKING-SECOND-PASS* *PREPROCESSING-PHASE*)
(IL:FUNCTIONS COMPILE-SCAN-DECLARE\: COMPILE-SCAN-DEFINE-FILE-INFO COMPILE-SCAN-MACROLET
COMPILE-SCAN-DEFINER COMPILE-SCAN-LOOSE-FORM COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS)
(IL:FUNCTIONS MERGE-FIRST-FORMS)
(IL:* IL:|;;| "for compiling definers")
(IL:* IL:|;;| "for compiling definers")
(IL:VARIABLES *LAP-FLG* *AUTOMATIC-SPECIAL-DECLARATIONS*)
(IL:FUNCTIONS COMPILE COMPILE-DEFINER)
@@ -75,11 +74,11 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(IL:FUNCTIONS COMPILE-DEFINER-DEFINER COMPILE-DEFINER-NAMED-PROGN
COMPILE-DEFINER-PROCESS-FUNCTION COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS)
(IL:* IL:|;;| "Arrange for correct compiler to be used.")
(IL:* IL:|;;| "Arrange for correct compiler to be used.")
(IL:PROP IL:FILETYPE IL:XCLC-TOP-LEVEL)
(IL:* IL:|;;| "Arrange for the correct makefile environment")
(IL:* IL:|;;| "Arrange for the correct makefile environment")
(IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-TOP-LEVEL)))
@@ -89,9 +88,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(DEFSTRUCT (COMPILER-CONTEXT (:FAST-ACCESSORS T)
(:CONC-NAME NIL)
(:COPIER NIL)
(:PREDICATE NIL))
(:CONC-NAME NIL)
(:COPIER NIL)
(:PREDICATE NIL))
SETF-SYMBOL-FUNCTION-FN
DEFINEQ-FN
DEFCONSTANT-FN
@@ -185,51 +184,50 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(DEFVAR *LOOSE-NAME* NIL)
(DEFUN COMPILE-FILE (INPUT-FILE &KEY (OUTPUT-FILE NIL)
(LAP-FILE NIL)
(ERROR-FILE NIL)
(ERRORS-TO-TERMINAL T)
(FILE-MANAGER-FORMAT NIL F-M-F-GIVEN)
(PROCESS-ENTIRE-FILE NIL P-E-F-GIVEN)
(LOAD NIL))
(LAP-FILE NIL)
(ERROR-FILE NIL)
(ERRORS-TO-TERMINAL T)
(FILE-MANAGER-FORMAT NIL F-M-F-GIVEN)
(PROCESS-ENTIRE-FILE NIL P-E-F-GIVEN)
(LOAD NIL)) (IL:* IL:\; "Edited 25-Feb-2026 21:33 by rmk")
(IL:* IL:|;;;| "Compiles the forms on Input-File, producing a FASL file.")
(IL:* IL:|;;;| "Compiles the forms on Input-File, producing a FASL file.")
(IL:* IL:|;;;| " :Output-File")
(IL:* IL:|;;;| " :Output-File")
(IL:* IL:|;;| "The name of a file to which binary code should be written.")
(IL:* IL:|;;| "The name of a file to which binary code should be written.")
(IL:* IL:|;;| " Defaults to Input-File with the extension '.dfasl'")
(IL:* IL:|;;| " Defaults to Input-File with the extension '.dfasl'")
(IL:* IL:|;;;| ":Lap-File")
(IL:* IL:|;;;| ":Lap-File")
(IL:* IL:|;;| "The name of a file to which LAP assemble code should be written.")
(IL:* IL:|;;| "The name of a file to which LAP assemble code should be written.")
(IL:* IL:|;;|
 " If T, defulats to Input-File with the extension '.dlap', if NIL, no LAP file is produced.")
(IL:* IL:|;;|
 " If T, defulats to Input-File with the extension '.dlap', if NIL, no LAP file is produced.")
(IL:* IL:|;;;| ":Error-FIle")
(IL:* IL:|;;;| ":Error-FIle")
(IL:* IL:|;;| "The name of a file to which compiler error messages should be written. Defaults like :Lap-File, but with the extension '.log'")
(IL:* IL:|;;| "The name of a file to which compiler error messages should be written. Defaults like :Lap-File, but with the extension '.log'")
(IL:* IL:|;;;| ":Errors-To-Terminal")
(IL:* IL:|;;;| ":Errors-To-Terminal")
(IL:* IL:|;;|
 "True if error messages should be sent to *ERROR-OUTPUT* as well as any :Error-File.")
(IL:* IL:|;;|
 "True if error messages should be sent to *ERROR-OUTPUT* as well as any :Error-File.")
(IL:* IL:|;;;| ":File-Manager-Format")
(IL:* IL:|;;;| ":File-Manager-Format")
(IL:* IL:|;;|
 "True if the file should be assumed to have been produced by the MAKEFILE function.")
(IL:* IL:|;;| "True if the file should be assumed to have been produced by the MAKEFILE function.")
(IL:* IL:|;;| "If not specified, we check the first non-blank character in the file. If that character is a left-paren, we assume that MAKEFILE made the file.")
(IL:* IL:|;;| "If not specified, we check the first non-blank character in the file. If that character is a left-paren, we assume that MAKEFILE made the file.")
(IL:* IL:|;;;| ":Process-Entire-File")
(IL:* IL:|;;;| ":Process-Entire-File")
(IL:* IL:|;;| "If true, the whole file is read in, evaluating those forms which are explicitly or implicitly EVAL-WHEN (OMPILE), before any code is generated. This allows macros to be defined after use, for example. This defaults to T if the file is declared or discovered to be in Interlisp format.")
(IL:* IL:|;;| "If true, the whole file is read in, evaluating those forms which are explicitly or implicitly EVAL-WHEN (OMPILE), before any code is generated. This allows macros to be defined after use, for example. This defaults to T if the file is declared or discovered to be in Interlisp format.")
(IL:* IL:|;;;| ":Load")
(IL:* IL:|;;;| ":Load")
(IL:* IL:|;;| "If true, definitions will be installed in the environment after they are compiled. If this is :SAVE, the any previous definitions are saved on the property list before the new ones are installed.")
(IL:* IL:|;;| "If true, definitions will be installed in the environment after they are compiled. If this is :SAVE, the any previous definitions are saved on the property list before the new ones are installed.")
(LET ((*ERROR-OUTPUT* *ERROR-OUTPUT*)
(*INPUT-STREAM* NIL)
@@ -246,10 +244,10 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(*OUTSTANDING-LOOSE-FORMS* NIL)
(*PROCESSED-FUNCTIONS* NIL)
(*UNKNOWN-FUNCTIONS* NIL)
(*INPUT-FILECOMS-VARIABLE* NIL) (IL:* IL:\;
 "Bound for the convenience of the optimizers on RPAQQ and PRETTYCOMPRINT.")
(*INPUT-FILECOMS-VARIABLE* NIL) (IL:* IL:\;
 "Bound for the convenience of the optimizers on RPAQQ and PRETTYCOMPRINT.")
(IL:* IL:|;;| "Rebind all of these both to set up a canonical environment inside the compiler and to protect the outside environment from anything that might happen during this file.")
(IL:* IL:|;;| "Rebind all of these both to set up a canonical environment inside the compiler and to protect the outside environment from anything that might happen during this file.")
(IL:SPECVARS T)
(IL:LOCALVARS IL:SYSLOCALVARS)
@@ -259,11 +257,11 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(IL:NLAML IL:NLAML)
(IL:LAMA IL:LAMA)
(IL:DONTCOMPILEFNS IL:DONTCOMPILEFNS))
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NLAMA
IL:NLAML IL:LAMA IL:DONTCOMPILEFNS))
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NLAMA IL:NLAML
IL:LAMA IL:DONTCOMPILEFNS))
(UNWIND-PROTECT
(PROGN
(IL:* IL:|;;| "Set up the input stream.")
(IL:* IL:|;;| "Set up the input stream.")
(LET ((PATH (OR (PROBE-FILE INPUT-FILE)
(PROBE-FILE (MERGE-PATHNAMES INPUT-FILE ".lisp")))))
@@ -281,19 +279,17 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(T (ERROR "The file \"~A\" is nonexistent or cannot be read.~%" INPUT-FILE
))))
(IL:* IL:|;;| "Set up the FASL output stream.")
(IL:* IL:|;;| "Set up the FASL output stream.")
(SETQ FASL-PATHNAME (COND
(OUTPUT-FILE (PATHNAME OUTPUT-FILE))
(T (MAKE-PATHNAME :TYPE
(STRING (LOCALLY (DECLARE (SPECIAL
IL:FASL.EXT)
)
(STRING (LOCALLY (DECLARE (SPECIAL IL:FASL.EXT))
IL:FASL.EXT))
:VERSION :NEWEST :DEFAULTS *INPUT-FILENAME*))))
(SETQ *FASL-HANDLE* (FASL:OPEN-FASL-HANDLE FASL-PATHNAME))
(IL:* IL:|;;| "Set up the LAP stream.")
(IL:* IL:|;;| "Set up the LAP stream.")
(WHEN LAP-FILE
(SETQ *LAP-STREAM* (OPEN (IF (EQ LAP-FILE T)
@@ -302,7 +298,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
LAP-FILE)
:DIRECTION :OUTPUT)))
(IL:* IL:|;;| "Set up the error output stream.")
(IL:* IL:|;;| "Set up the error output stream.")
(WHEN ERROR-FILE
(SETQ ERROR-FILE-STREAM (OPEN (IF (EQ ERROR-FILE T)
@@ -317,8 +313,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
*ERROR-OUTPUT*)
ERROR-FILE-STREAM))
(IL:* IL:|;;|
 "Fix up the default values of FILE-MANAGER-FORMAT and PROCESS-ENTIRE-FILE.")
(IL:* IL:|;;|
 "Fix up the default values of FILE-MANAGER-FORMAT and PROCESS-ENTIRE-FILE.")
(IF (NOT F-M-F-GIVEN)
(SETQ FILE-MANAGER-FORMAT (EQ (IL:SKIPSEPRCODES *INPUT-STREAM* IL:FILERDTBL)
@@ -326,22 +322,22 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(IF (NOT P-E-F-GIVEN)
(SETQ PROCESS-ENTIRE-FILE FILE-MANAGER-FORMAT))
(IL:* IL:|;;| "Pick the right readtable and do the compilation.")
(IL:* IL:|;;| "Pick the right readtable and do the compilation.")
(IL:WITH-READER-ENVIRONMENT (IF FILE-MANAGER-FORMAT
IL:*OLD-INTERLISP-READ-ENVIRONMENT*
IL:*DEFINE-FILE-INFO-ENV*
IL:*COMMON-LISP-READ-ENVIRONMENT*)
(START-COMPILATION)
(PROCESS-FORMS PROCESS-ENTIRE-FILE)
(FINISH-COMPILATION)
(SETQ COMPILATION-SUCCEEDED T)
(IL:* IL:|;;|
 "Return the DFASL pathname so that people can say, for example, (LOAD (COMPILE-FILE ...))")
(IL:* IL:|;;|
 "Return the DFASL pathname so that people can say, for example, (LOAD (COMPILE-FILE ...))")
FASL-PATHNAME))
(IL:* IL:|;;| "The compilation is over. Close all of the streams. If the compilations did not succeed (that is, we have aborted it), then delete the FASL file as well rather than leave garbage around.")
(IL:* IL:|;;| "The compilation is over. Close all of the streams. If the compilations did not succeed (that is, we have aborted it), then delete the FASL file as well rather than leave garbage around.")
(IF (STREAMP *INPUT-STREAM*)
(CLOSE *INPUT-STREAM*))
@@ -352,9 +348,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(IF (STREAMP *LAP-STREAM*)
(CLOSE *LAP-STREAM*)))))
(DEFUN START-COMPILATION () (IL:* IL:\; "Edited 19-Sep-2020 22:02 by rmk:")
(DEFUN START-COMPILATION () (IL:* IL:\; "Edited 19-Sep-2020 22:02 by rmk:")
(IL:* IL:|;;;| "Write out banners on the various output files.")
(IL:* IL:|;;;| "Write out banners on the various output files.")
(FLET ((DATE-STRING (UNIV-TIME)
(MULTIPLE-VALUE-BIND (SECONDS MINUTES HOUR DATE MONTH YEAR DAY-OF-WEEK)
@@ -370,7 +366,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
(LET ((FASL-STREAM (FASL:BEGIN-TEXT *FASL-HANDLE*))
(FILECREATED (IL:READ-FILECREATED *INPUT-STREAM*)))
(IL:* IL:|;;| "RMK: This had a complicated format, didn't work, so I reverted to printout. PRIN3 to stop wrap around")
(IL:* IL:|;;| "RMK: This had a complicated format, didn't work, so I reverted to printout. PRIN3 to stop wrap around")
(IL:PRINTOUT FASL-STREAM "XCL Compiler output for source file " IL:\#
(IL:PRIN3 (OR (CADDR FILECREATED)
@@ -395,9 +391,9 @@ LAP file created ~A.~%~%"
(DEFUN FINISH-COMPILATION ()
(IL:* IL:|;;;| "Clean up after the compilation.")
(IL:* IL:|;;;| "Clean up after the compilation.")
(IL:* IL:|;;| "Remove this file from IL:NOTCOMPILEDFILES for CLEANUP.")
(IL:* IL:|;;| "Remove this file from IL:NOTCOMPILEDFILES for CLEANUP.")
(LOCALLY (DECLARE (IL:GLOBALVARS IL:NOTCOMPILEDFILES))
(SETQ IL:NOTCOMPILEDFILES (REMOVE (INTERN (LET ((TYPE (PATHNAME-TYPE *INPUT-FILENAME*)))
@@ -411,13 +407,13 @@ LAP file created ~A.~%~%"
"INTERLISP")
IL:NOTCOMPILEDFILES)))
(IL:* IL:|;;| "Possibly warn about unknown functions encountered during compilation.")
(IL:* IL:|;;| "Possibly warn about unknown functions encountered during compilation.")
(WARN-ABOUT-UNKNOWN-FUNCTIONS))
(DEFUN SCAN-ONE-FORM (FORM COMPILER-CONTEXT)
(IL:* IL:|;;| "Assumes sedit like comments have already been stripped ")
(IL:* IL:|;;| "Assumes sedit like comments have already been stripped ")
(IF (ATOM FORM)
FORM
@@ -433,8 +429,7 @@ LAP file created ~A.~%~%"
(CERROR "Ignore this DEFMACRO." "~S is not a legal macro name." NAME)
)
(T (UNLESS *MAKING-SECOND-PASS*
(ESTABLISH-MACRO-IN-COMPILER NAME (CRACK-DEFMACRO
FORM)))
(ESTABLISH-MACRO-IN-COMPILER NAME (CRACK-DEFMACRO FORM)))
(SCAN-ONE-FORM (OPTIMIZE-AND-MACROEXPAND-1 FORM)
COMPILER-CONTEXT)))))
((EVAL-WHEN) (IF (NOT (AND (LISTP (SECOND FORM))
@@ -476,12 +471,11 @@ LAP file created ~A.~%~%"
VALUE)))))))
((DEFCONSTANT) (COMPILER-APPLY DEFCONSTANT COMPILER-CONTEXT FORM))
((IL:DECLARE\:) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT FORM))
((IL:SETF-SYMBOL-FUNCTION) (COMPILER-APPLY IL:SETF-SYMBOL-FUNCTION COMPILER-CONTEXT
FORM))
((IL:SETF-SYMBOL-FUNCTION) (COMPILER-APPLY IL:SETF-SYMBOL-FUNCTION COMPILER-CONTEXT FORM))
((IL:DEFINEQ) (COMPILER-APPLY IL:DEFINEQ COMPILER-CONTEXT FORM))
((IL:DEFINE-FILE-INFO) (COMPILER-APPLY IL:DEFINE-FILE-INFO COMPILER-CONTEXT FORM))
((MAKE-PACKAGE IN-PACKAGE SHADOW SHADOWING-IMPORT EXPORT UNEXPORT USE-PACKAGE
UNUSE-PACKAGE IMPORT DEFPACKAGE) (COMPILER-APPLY PACKAGE-FORM COMPILER-CONTEXT
UNUSE-PACKAGE IMPORT DEFPACKAGE) (COMPILER-APPLY PACKAGE-FORM COMPILER-CONTEXT
FORM))
((PROCLAIM) (COMPILER-APPLY PROCLAIM COMPILER-CONTEXT FORM))
((COMPILER-LET) (COMPILER-APPLY COMPILER-LET COMPILER-CONTEXT FORM))
@@ -522,11 +516,11 @@ LAP file created ~A.~%~%"
(DOLIST (PAIR (UNKNOWN-FUNCTION-WARNING-CALL-LIST CONDITION))
(FORMAT T " ~S -- called from " (CAR PAIR))
(IL:* IL:|;;|
 "I almost used this hairy thing, but FORMAT is too slow... Aren't you glad?")
(IL:* IL:|;;|
 "I almost used this hairy thing, but FORMAT is too slow... Aren't you glad?")
(IL:* IL:|;;|
 "\"~:[nowhere?!~;~:*~{~#[~;~S~;~S and ~S~:;~@{~#[~;and ~]~S~^, ~}~]~}.~]~%\"")
(IL:* IL:|;;|
 "\"~:[nowhere?!~;~:*~{~#[~;~S~;~S and ~S~:;~@{~#[~;and ~]~S~^, ~}~]~}.~]~%\"")
(COND
((NULL (CDR PAIR))
@@ -563,32 +557,32 @@ LAP file created ~A.~%~%"
(DEFUN WARN-ABOUT-UNKNOWN-FUNCTIONS ()
(IL:* IL:|;;;| "If there's anything on *UNKNOWN-FUNCTIONS*, issue a summary and warning.")
(IL:* IL:|;;;| "If there's anything on *UNKNOWN-FUNCTIONS*, issue a summary and warning.")
(WHEN (NOT (NULL *UNKNOWN-FUNCTIONS*))
(WARN 'UNKNOWN-FUNCTION-WARNING :CALL-LIST *UNKNOWN-FUNCTIONS*)))
(DEFVAR *PROCESSED-FUNCTIONS*
(IL:* IL:|;;;| "A list of the names of the global functions processed during this compilation. Used in conjunction with *UNKNOWN-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
(IL:* IL:|;;;| "A list of the names of the global functions processed during this compilation. Used in conjunction with *UNKNOWN-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
)
(DEFVAR *UNKNOWN-FUNCTIONS*
(IL:* IL:|;;;| "A list containing the names of undefined global functions called from code in the current compilation. Actually, it's an AList mapping the unknown function to the list of functions in which it is called. Used in conjunction with *PROCESSED-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
(IL:* IL:|;;;| "A list containing the names of undefined global functions called from code in the current compilation. Actually, it's an AList mapping the unknown function to the list of functions in which it is called. Used in conjunction with *PROCESSED-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
)
(DEFVAR *CURRENT-FUNCTION*
(IL:* IL:|;;;| "The name of the unit currently being compiled.")
(IL:* IL:|;;;| "The name of the unit currently being compiled.")
)
(DEFINE-CONDITION ASSEMBLER-ERROR
(IL:* IL:|;;;| "Signalled by an assembler when it encounters an unrecoverable error. The compiler catches such, prints an error message, and continues with the next form on the file.")
(IL:* IL:|;;;| "Signalled by an assembler when it encounters an unrecoverable error. The compiler catches such, prints an error message, and continues with the next form on the file.")
(ERROR)
(FORMAT-STRING FORMAT-ARGUMENTS)
@@ -620,33 +614,33 @@ LAP file created ~A.~%~%"
(DEFVAR *BLOCK-HASH-TABLE* NIL
(IL:* IL:|;;;| "A mapping from function names to lists of BLOCK-DECL structures describing blocks that include that function. Initialized from the list of BLOCK: declarations gathered into *BLOCKS* (q.v.) during the preprocessing scan.")
(IL:* IL:|;;;| "A mapping from function names to lists of BLOCK-DECL structures describing blocks that include that function. Initialized from the list of BLOCK: declarations gathered into *BLOCKS* (q.v.) during the preprocessing scan.")
)
(DEFVAR *BLOCKS* NIL
(IL:* IL:|;;;| "A list of the Interlisp block descriptions found on the file. This list is added to during the preprocessing scan of the file and then used for initialising *BLOCK-HASH-TABLE* (q.v.)")
(IL:* IL:|;;;| "A list of the Interlisp block descriptions found on the file. This list is added to during the preprocessing scan of the file and then used for initialising *BLOCK-HASH-TABLE* (q.v.)")
)
(DEFVAR *CURRENT-BLOCK* NIL
(IL:* IL:|;;;| "Bound during compilation of a LAMBDA to the BLOCK-DECL structure describing the block containing the current function. This is NIL if the function is not a part of any block.")
(IL:* IL:|;;;| "Bound during compilation of a LAMBDA to the BLOCK-DECL structure describing the block containing the current function. This is NIL if the function is not a part of any block.")
)
(DEFSTRUCT (BLOCK-DECL (:INLINE NIL))
(IL:* IL:|;;;|
"A BLOCK-DECL holds the information describing a particular Interlisp BLOCK: declaration.")
(IL:* IL:|;;;|
"A BLOCK-DECL holds the information describing a particular Interlisp BLOCK: declaration.")
(IL:* IL:|;;;| "NAME is the symbol naming the block or NIL if this is only a pseudo-block.")
(IL:* IL:|;;;| "NAME is the symbol naming the block or NIL if this is only a pseudo-block.")
(IL:* IL:|;;;|
"FN-NAME-MAP is an AList mapping internal function names to their new \\BLOCK/FN style name.")
(IL:* IL:|;;;|
"FN-NAME-MAP is an AList mapping internal function names to their new \\BLOCK/FN style name.")
(IL:* IL:|;;;| "SPECVARS, LOCALVARS, LOCALFREEVARS and GLOBALVARS contain the values those variables should have during the compilation of functions in this block.")
(IL:* IL:|;;;| "SPECVARS, LOCALVARS, LOCALFREEVARS and GLOBALVARS contain the values those variables should have during the compilation of functions in this block.")
NAME
FN-NAME-MAP
@@ -657,7 +651,7 @@ LAP file created ~A.~%~%"
(DEFUN SET-UP-BLOCK-DECLS (DECLS)
(IL:* IL:|;;;| "Parse the given list of Interlisp BLOCK: declarations and return a hash-table mapping functions named therein to a list of the BLOCK-DECLs representing decls mentioning that function.")
(IL:* IL:|;;;| "Parse the given list of Interlisp BLOCK: declarations and return a hash-table mapping functions named therein to a list of the BLOCK-DECLs representing decls mentioning that function.")
(LET ((HASH-TABLE (MAKE-HASH-TABLE)))
(DOLIST (DECL DECLS)
@@ -670,9 +664,9 @@ LAP file created ~A.~%~%"
(NOT-RENAMED-FNS (CONS BLOCK-NAME (UNION IL:RETFNS IL:NOLINKFNS)))
(FNS NIL))
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS
IL:NOLINKFNS))
IL:NOLINKFNS))
(IL:* IL:|;;| "We do this next bit because BCOMPL2 does it.")
(IL:* IL:|;;| "We do this next bit because BCOMPL2 does it.")
(COND
((NULL BLOCK-NAME)
@@ -681,7 +675,7 @@ LAP file created ~A.~%~%"
(T (SETQ IL:LOCALVARS T)
(SETQ IL:SPECVARS IL:SYSSPECVARS)))
(IL:* IL:|;;| "For each item in the declaration, either add it to the list of functions or make the appropriate modifications to the named variable.")
(IL:* IL:|;;| "For each item in the declaration, either add it to the list of functions or make the appropriate modifications to the named variable.")
(DOLIST (ITEM (CDR DECL))
(COND
@@ -709,8 +703,8 @@ LAP file created ~A.~%~%"
"DONTCOMPILEFNS is not supported in BLOCK: declarations."
))
((IL:BLKAPPLYFNS IL:NOLINKFNS IL:RETFNS IL:ENTRIES)
(IL:* IL:\;
 "These functions should not be renamed, according to BYTEBLOCKCOMPILE2.")
(IL:* IL:\;
 "These functions should not be renamed, according to BYTEBLOCKCOMPILE2.")
(WHEN (CONSP (CDR ITEM))
(SETQ NOT-RENAMED-FNS (APPEND (CDR ITEM)
NOT-RENAMED-FNS))))
@@ -729,14 +723,14 @@ LAP file created ~A.~%~%"
IL:GLOBALVARS)
(LET* ((BLOCK-NAME-STRING (STRING BLOCK-NAME))
(BLOCK-PACKAGE (SYMBOL-PACKAGE BLOCK-NAME)))
(UNLESS (NULL BLOCK-NAME) (IL:* IL:\;
 "NIL blocks don't do renaming.")
(UNLESS (NULL BLOCK-NAME) (IL:* IL:\;
 "NIL blocks don't do renaming.")
(SETF (BLOCK-DECL-FN-NAME-MAP BD)
(IL:|for| FN IL:|in| (NSET-DIFFERENCE FNS NOT-RENAMED-FNS)
IL:|collect| (CONS FN (INTERN (CONCATENATE 'STRING "\\"
BLOCK-NAME-STRING "/"
(STRING FN))
BLOCK-PACKAGE))))))))
BLOCK-NAME-STRING "/"
(STRING FN))
BLOCK-PACKAGE))))))))
HASH-TABLE))
@@ -761,8 +755,8 @@ LAP file created ~A.~%~%"
(RETURN NIL))))))))
(DEFUN COMPILE-AND-DUMP (NAME DEFN KIND)
(LET ((*CURRENT-BLOCK* NIL) (IL:* IL:\;
 "So that we aren't dependent upon the top-level binding.")
(LET ((*CURRENT-BLOCK* NIL) (IL:* IL:\;
 "So that we aren't dependent upon the top-level binding.")
)
(COND
((AND (SYMBOLP NAME)
@@ -783,7 +777,7 @@ LAP file created ~A.~%~%"
(IL:LOCALFREEVARS (BLOCK-DECL-LOCALFREEVARS *CURRENT-BLOCK*))
(IL:GLOBALVARS (BLOCK-DECL-GLOBALVARS *CURRENT-BLOCK*)))
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS
IL:GLOBALVARS))
IL:GLOBALVARS))
(COMPILE-AND-DUMP-1 NEW-NAME DEFN KIND)))))))
(T (COMPILE-AND-DUMP-1 NAME DEFN KIND)))))
@@ -824,14 +818,14 @@ LAP file created ~A.~%~%"
(SYMBOL-FUNCTION NAME)))
(SETF (SYMBOL-FUNCTION NAME)
(D-ASSEM:INTERN-DCODE DCODE)))
(:ONE-SHOT (LET ((IL:FILEPKGFLG NIL)) (IL:* IL:\;
 "so that things don't get marked as changed when you execute the one-shot.")
(:ONE-SHOT (LET ((IL:FILEPKGFLG NIL)) (IL:* IL:\;
 "so that things don't get marked as changed when you execute the one-shot.")
(DECLARE (SPECIAL IL:FILEPKGFLG))
(FUNCALL (D-ASSEM:INTERN-DCODE DCODE))))))))
(DEFUN COMPILE-ONE-LAMBDA (NAME DEFN)
(IL:* IL:|;;;| "Return a LAP function for the given function definition. NAME is the symbol with which the definition will be associated at load time and DEFN is the LAMBDA-expression to be compiled.")
(IL:* IL:|;;;| "Return a LAP function for the given function definition. NAME is the symbol with which the definition will be associated at load time and DEFN is the LAMBDA-expression to be compiled.")
(LET ((*CONTEXT* *NULL-CONTEXT*)
(*AUTOMATIC-SPECIAL-DECLARATIONS* NIL))
@@ -844,9 +838,9 @@ LAP file created ~A.~%~%"
LAP-CODE)))
(DEFUN OPTIMIZE-AND-MACROEXPAND (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*)
(CONTEXT *CONTEXT*))
(CONTEXT *CONTEXT*))
(IL:* IL:|;;;| "Analagous to MACROEXPAND: keep trying OPTIMIZE-AND-MACROEXPAND-1 until it fails to change the form.")
(IL:* IL:|;;;| "Analagous to MACROEXPAND: keep trying OPTIMIZE-AND-MACROEXPAND-1 until it fails to change the form.")
(PROG (NEW-FORM CHANGED-P)
(MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P)
@@ -861,9 +855,9 @@ LAP file created ~A.~%~%"
(RETURN (VALUES NEW-FORM T)))))
(DEFUN OPTIMIZE-AND-MACROEXPAND-1 (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*)
(CONTEXT *CONTEXT*))
(CONTEXT *CONTEXT*))
(IL:* IL:|;;;| "If the given form is a list, then look for macros and optimizers defined for its CAR. Return two values like MACROEXPAND-1.")
(IL:* IL:|;;;| "If the given form is a list, then look for macros and optimizers defined for its CAR. Return two values like MACROEXPAND-1.")
(LET ((*NEW-COMPILER-IS-EXPANDING* T))
(COND
@@ -871,23 +865,23 @@ LAP file created ~A.~%~%"
(NOT (SYMBOLP (CAR FORM))))
(VALUES FORM NIL))
(T
(IL:* IL:|;;| "Check for compiler optimizers.")
(IL:* IL:|;;| "Check for compiler optimizers.")
(LET ((OPTIMIZERS (OPTIMIZER-LIST (CAR FORM))))
(WHEN (AND (NOT (NULL OPTIMIZERS))
(NOT (ENV-FBOUNDP ENVIRONMENT (CAR FORM)
:LEXICAL-ONLY T))
(NOT (ENV-INLINE-DISALLOWED ENVIRONMENT (CAR FORM))))
(IL:* IL:\;
 "Optimizers cannot apply to lexical functions or macros or to functions declared NOTINLINE.")
(IL:* IL:\;
 "Optimizers cannot apply to lexical functions or macros or to functions declared NOTINLINE.")
(DOLIST (OPT-FN OPTIMIZERS)
(LET ((RESULT (FUNCALL OPT-FN FORM ENVIRONMENT CONTEXT)))
(UNLESS (OR (EQ RESULT 'PASS)
(EQ RESULT 'IL:IGNOREMACRO)
(EQ RESULT FORM))(IL:* IL:\; "This optimizer fired.")
(EQ RESULT FORM))(IL:* IL:\; "This optimizer fired.")
(RETURN-FROM OPTIMIZE-AND-MACROEXPAND-1 (VALUES RESULT T)))))))
(IL:* IL:|;;| "Check for a macro expansion function.")
(IL:* IL:|;;| "Check for a macro expansion function.")
(MACROEXPAND-1 FORM ENVIRONMENT)))))
@@ -919,47 +913,45 @@ LAP file created ~A.~%~%"
(IL:RPAQQ (IF (EQ (SECOND FORM)
*INPUT-FILECOMS-VARIABLE*)
(IL:* IL:|;;|
 "Don't remove comments from file coms")
(IL:* IL:|;;| "Don't remove comments from file coms")
FORM
(REMOVE-COMMENTS FORM)))
(IL:DEFCLASS
(IL:* IL:|;;|
 "Don't remove comments from LOOPS DEFCLASS forms")
(IL:* IL:|;;| "Don't remove comments from LOOPS DEFCLASS forms")
FORM)
(IL:DATATYPE
(IL:* IL:|;;| "Don't remove comments from record declarations")
(IL:* IL:|;;| "Don't remove comments from record declarations")
FORM)
(IL:RECORD
(IL:* IL:|;;| "Don't remove comments from record declarations")
(IL:* IL:|;;| "Don't remove comments from record declarations")
FORM)
(IL:BLOCKRECORD
(IL:* IL:|;;| "Don't remove comments from record declarations")
(IL:* IL:|;;| "Don't remove comments from record declarations")
FORM)
(IL:DECLARE\:
(IL:* IL:|;;|
 "Process each form inside this as though it were at top-level")
(IL:* IL:|;;|
 "Process each form inside this as though it were at top-level")
(IL:FOR X IL:IN FORM
IL:COLLECT (COND
((NOT (CONSP X))
X)
(T (CASE (CAR X)
(IL:DEFCLASS X)
(IL:DATATYPE X)
(IL:RECORD X)
(IL:BLOCKRECORD X)
(OTHERWISE (REMOVE-COMMENTS X)))))))
((NOT (CONSP X))
X)
(T (CASE (CAR X)
(IL:DEFCLASS X)
(IL:DATATYPE X)
(IL:RECORD X)
(IL:BLOCKRECORD X)
(OTHERWISE (REMOVE-COMMENTS X)))))))
(OTHERWISE (REMOVE-COMMENTS FORM)))))
(SCAN-ONE-FORM NEW-FORM *COMPILE-SCAN-CONTEXT*))
(SCAN-ONE-FORM FORM *COMPILE-FILE-CONTEXT*)))
@@ -988,9 +980,10 @@ LAP file created ~A.~%~%"
(WHEN *EVAL-WHEN-COMPILE* (EVAL FORM))
(LET ((NAME (SECOND NAME-FORM))
(DEFINITION (SECOND FUNCTION-FORM)))
(COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~a"
(CAR DEFINITION)
NAME)
(COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~a" (CAR
DEFINITION
)
NAME)
NAME DEFINITION)))
(T (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM)))))
@@ -1002,8 +995,8 @@ LAP file created ~A.~%~%"
(SECOND DEFN)
(CONS 'IL:LAMBDA (CDR DEFN)))))
(COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~s"
(CAR REAL-DEFN)
(CAR DEFN))
(CAR REAL-DEFN)
(CAR DEFN))
(CAR DEFN)
REAL-DEFN)))
(CDR FORM)))
@@ -1019,10 +1012,10 @@ LAP file created ~A.~%~%"
VALUE)
(ENV-DECLARE-A-GLOBAL (FIND-TOP-ENVIRONMENT *ENVIRONMENT*)
SYMBOL)))
(SCAN-ONE-FORM `(NAMED-PROGN DEFCONSTANT ,SYMBOL
(LOCALLY (DECLARE (GLOBAL ,SYMBOL))
,(EXPAND-DEFINER 'DEFCONSTANT (REMOVE-COMMENTS FORM)
*ENVIRONMENT*)))
(SCAN-ONE-FORM `(NAMED-PROGN DEFCONSTANT ,SYMBOL (LOCALLY (DECLARE (GLOBAL ,SYMBOL))
,(EXPAND-DEFINER 'DEFCONSTANT
(REMOVE-COMMENTS FORM)
*ENVIRONMENT*)))
COMPILER-CONTEXT)))
(DEFUN COMPILE-FILE-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T))
@@ -1044,9 +1037,8 @@ LAP file created ~A.~%~%"
((IL:COPYWHEN) (SETQ DOCOPY (IL:EVAL (CAR (SETQ TAIL (CDR TAIL))))))
((IL:FIRST) )
((IL:NOTFIRST IL:COMPILERVARS) )
(OTHERWISE (COMPILER-MESSAGE
"Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL))))
)
(OTHERWISE (COMPILER-MESSAGE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%"
(CAR TAIL)))))
((EQ 'IL:DECLARE\: (CAR (CAR TAIL)))
(COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL)
DOCOPY))
@@ -1068,11 +1060,13 @@ LAP file created ~A.~%~%"
IL:FILECREATEDLOC)
(DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC))
(EVAL FORM))
(COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT
`(LET ((*STANDARD-INPUT* (OPEN "{Null}" :DIRECTION :OUTPUT))
IL:FILECREATEDLOC)
(DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC))
,FORM))
(COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT `(LET ((*STANDARD-INPUT* (OPEN "{Null}"
:DIRECTION
:OUTPUT))
IL:FILECREATEDLOC)
(DECLARE (SPECIAL *STANDARD-INPUT*
IL:FILECREATEDLOC))
,FORM))
(COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))
(DEFUN COMPILE-FILE-PACKAGE-FORM (COMPILER-CONTEXT FORM)
@@ -1229,7 +1223,7 @@ LAP file created ~A.~%~%"
(DEFUN CRACK-DEFMACRO (FORM)
(IL:* IL:|;;;| "FORM is a call to DEFMACRO. Return two values: the LAMBDA-expression representing the expansion function for the macro and the documentation string, if present.")
(IL:* IL:|;;;| "FORM is a call to DEFMACRO. Return two values: the LAMBDA-expression representing the expansion function for the macro and the documentation string, if present.")
(LET ((NAME (SECOND FORM))
(ARG-LIST (THIRD FORM))
@@ -1245,7 +1239,7 @@ LAP file created ~A.~%~%"
(DEFUN ESTABLISH-MACRO-IN-COMPILER (NAME EXPN-FN)
(IL:* IL:|;;;| "Arrange for the symbol NAME to refer to a macro with the given expansion-function EXPN-FN within this compilation.")
(IL:* IL:|;;;| "Arrange for the symbol NAME to refer to a macro with the given expansion-function EXPN-FN within this compilation.")
(ENV-BIND-FUNCTION (FIND-TOP-ENVIRONMENT *ENVIRONMENT*)
NAME :MACRO EXPN-FN))
@@ -1261,18 +1255,18 @@ LAP file created ~A.~%~%"
(DEFVAR *MAKING-SECOND-PASS* NIL
(IL:* IL:|;;;| "Bound to T during second pass over saved forms; used for :Process-Entire-File option to compile-file.")
(IL:* IL:|;;;| "Bound to T during second pass over saved forms; used for :Process-Entire-File option to compile-file.")
)
(DEFVAR *PREPROCESSING-PHASE* NIL
(IL:* IL:|;;;| "Bound to T during the preprocessing phase so that inferiors can tell.")
(IL:* IL:|;;;| "Bound to T during the preprocessing phase so that inferiors can tell.")
)
(DEFUN COMPILE-SCAN-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T)
(DOFIRST NIL))
(DOFIRST NIL))
(LET ((FIRST-FORMS NIL)
(IL:DFNFLG IL:DFNFLG)
(*EVAL-WHEN-COMPILE* *EVAL-WHEN-COMPILE*))
@@ -1295,9 +1289,8 @@ LAP file created ~A.~%~%"
((IL:FIRST) (SETQ DOFIRST T))
((IL:NOTFIRST) (SETQ DOFIRST NIL))
((IL:COMPILERVARS) (SETQ IL:DFNFLG T))
(OTHERWISE (COMPILER-MESSAGE
"Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL))))
)
(OTHERWISE (COMPILER-MESSAGE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%"
(CAR TAIL)))))
((EQ 'IL:DECLARE\: (CAR (CAR TAIL)))
(COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL)
DOCOPY DOFIRST))
@@ -1416,7 +1409,7 @@ LAP file created ~A.~%~%"
(*UNKNOWN-FUNCTIONS* NIL)
(*CURRENT-FUNCTION* NAME)
(*INPUT-STREAM* NIL)
(*LAP-FLG* LAP) (IL:* IL:\; "FXAR-111")
(*LAP-FLG* LAP) (IL:* IL:\; "FXAR-111")
(COMPILED-DEFN (RAW-COMPILE NAME DEFN)))
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS))
(WARN-ABOUT-UNKNOWN-FUNCTIONS)
@@ -1516,7 +1509,7 @@ LAP file created ~A.~%~%"
(LET ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*))
COMPILED-DEFN)
(IL:* IL:|;;| "The resulting function is defined locally, so we have to compile for the host architecture rather than the target architecture:")
(IL:* IL:|;;| "The resulting function is defined locally, so we have to compile for the host architecture rather than the target architecture:")
(SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*)
*HOST-ARCHITECTURE*)
@@ -1531,20 +1524,20 @@ LAP file created ~A.~%~%"
(DEFUN COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT)
(IL:* IL:|;;|
 "Compile any outstanding loose forms in the context of a structure definition being compiled")
(IL:* IL:|;;|
 "Compile any outstanding loose forms in the context of a structure definition being compiled")
(WHEN (NOT (NULL *OUTSTANDING-LOOSE-FORMS*))
(LET* ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*))
COMPILED-DEFN)
(IL:* IL:|;;| "The resulting function is executed locally, so have to compile for the host architecture rather than the target architecture:")
(IL:* IL:|;;| "The resulting function is executed locally, so have to compile for the host architecture rather than the target architecture:")
(SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*)
*HOST-ARCHITECTURE*)
(SETQ COMPILED-DEFN (RAW-COMPILE *LOOSE-NAME* `(LAMBDA NIL ,@(REVERSE
*OUTSTANDING-LOOSE-FORMS*
))))
))))
(SETQ *OUTSTANDING-LOOSE-FORMS* NIL)
(FUNCALL COMPILED-DEFN))))
@@ -1561,36 +1554,37 @@ LAP file created ~A.~%~%"
(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
(DEFPACKAGE "COMPILER"
(:USE "LISP" "XCL"))))
(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991
1994 2020))
(DEFPACKAGE "COMPILER" (:USE "LISP"
"XCL"))))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL (7050 7194 (COMPILER-ERROR 7050 . 7194)) (8749 17618 (COMPILE-FILE 8749 . 17618)) (
17620 20017 (START-COMPILATION 17620 . 20017)) (20019 21292 (FINISH-COMPILATION 20019 . 21292)) (21294
26872 (SCAN-ONE-FORM 21294 . 26872)) (26874 27071 (FUNCTION-P 26874 . 27071)) (28998 29614 (
CHECK-FOR-UNKNOWN-FUNCTION 28998 . 29614)) (29616 29870 (WARN-ABOUT-UNKNOWN-FUNCTIONS 29616 . 29870))
(31345 31475 (ASSEMBLER-ERROR 31345 . 31475)) (33238 38333 (SET-UP-BLOCK-DECLS 33238 . 38333)) (38481
39021 (CONSTANT-EXPRESSION-P 38481 . 39021)) (39023 40665 (COMPILE-AND-DUMP 39023 . 40665)) (40667
42619 (COMPILE-AND-DUMP-1 40667 . 42619)) (42621 43312 (COMPILE-ONE-LAMBDA 42621 . 43312)) (43314
44035 (OPTIMIZE-AND-MACROEXPAND 43314 . 44035)) (44037 45685 (OPTIMIZE-AND-MACROEXPAND-1 44037 . 45685
)) (45893 49547 (PROCESS-FORMS 45893 . 49547)) (49549 49684 (MAYBE-REMOVE-COMMENTS 49549 . 49684)) (
49686 50599 (COMPILE-FILE-SETF-SYMBOL-FUNCTION 49686 . 50599)) (50601 51400 (COMPILE-FILE-DEFINEQ
50601 . 51400)) (51402 52329 (COMPILE-FILE-DEFCONSTANT 51402 . 52329)) (52331 54264 (
COMPILE-FILE-DECLARE\: 52331 . 54264)) (54266 54828 (COMPILE-FILE-DEFINE-FILE-INFO 54266 . 54828)) (
54830 55074 (COMPILE-FILE-PACKAGE-FORM 54830 . 55074)) (55076 57795 (COMPILE-FILE-PROCLAMATION 55076
. 57795)) (57797 59208 (COMPILE-FILE-COMPILER-LET 57797 . 59208)) (59210 59890 (COMPILE-FILE-MACROLET
59210 . 59890)) (59892 60882 (COMPILE-FILE-DEFINER 59892 . 60882)) (60884 61812 (
COMPILE-FILE-NAMED-PROGN 60884 . 61812)) (61814 62464 (COMPILE-FILE-OUTSTANDING-LOOSE-FORMS 61814 .
62464)) (62466 62608 (COMPILE-FILE-LOOSE-FORM 62466 . 62608)) (62610 62929 (
COMPILE-FILE-PROCESS-FUNCTION 62610 . 62929)) (62931 63608 (CRACK-DEFMACRO 62931 . 63608)) (63610
63893 (ESTABLISH-MACRO-IN-COMPILER 63610 . 63893)) (64587 66834 (COMPILE-SCAN-DECLARE\: 64587 . 66834)
) (66836 67198 (COMPILE-SCAN-DEFINE-FILE-INFO 66836 . 67198)) (67200 68114 (COMPILE-SCAN-MACROLET
67200 . 68114)) (68116 68751 (COMPILE-SCAN-DEFINER 68116 . 68751)) (68753 68886 (
COMPILE-SCAN-LOOSE-FORM 68753 . 68886)) (68888 68962 (COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS 68888 .
68962)) (68964 69412 (MERGE-FIRST-FORMS 68964 . 69412)) (69537 71788 (COMPILE 69537 . 71788)) (71790
72043 (COMPILE-DEFINER 71790 . 72043)) (72045 73084 (COMPILE-FORM 72045 . 73084)) (73086 73958 (
RAW-COMPILE 73086 . 73958)) (73960 75059 (COMPILE-DEFINER-DEFINER 73960 . 75059)) (75061 75899 (
COMPILE-DEFINER-NAMED-PROGN 75061 . 75899)) (75901 76736 (COMPILE-DEFINER-PROCESS-FUNCTION 75901 .
76736)) (76738 77694 (COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS 76738 . 77694)))))
(IL:FILEMAP (NIL (6860 7004 (COMPILER-ERROR 6860 . 7004)) (7006 7507 (COMPILER-APPLY 7006 . 7507)) (
8559 17297 (COMPILE-FILE 8559 . 17297)) (17299 19704 (START-COMPILATION 17299 . 19704)) (19706 20979 (
FINISH-COMPILATION 19706 . 20979)) (20981 26437 (SCAN-ONE-FORM 20981 . 26437)) (26439 26636 (
FUNCTION-P 26439 . 26636)) (26638 26760 (COMPILER-MESSAGE 26638 . 26760)) (26762 26850 (
COMPILING-MESSAGE 26762 . 26850)) (26852 26919 (DONE-MESSAGE 26852 . 26919)) (28567 29183 (
CHECK-FOR-UNKNOWN-FUNCTION 28567 . 29183)) (29185 29439 (WARN-ABOUT-UNKNOWN-FUNCTIONS 29185 . 29439))
(30914 31044 (ASSEMBLER-ERROR 30914 . 31044)) (32807 37890 (SET-UP-BLOCK-DECLS 32807 . 37890)) (38038
38578 (CONSTANT-EXPRESSION-P 38038 . 38578)) (38580 40220 (COMPILE-AND-DUMP 38580 . 40220)) (40222
42176 (COMPILE-AND-DUMP-1 40222 . 42176)) (42178 42869 (COMPILE-ONE-LAMBDA 42178 . 42869)) (42871
43588 (OPTIMIZE-AND-MACROEXPAND 42871 . 43588)) (43590 45236 (OPTIMIZE-AND-MACROEXPAND-1 43590 . 45236
)) (45238 45442 (EXPAND-DEFINER 45238 . 45442)) (45444 48977 (PROCESS-FORMS 45444 . 48977)) (48979
49114 (MAYBE-REMOVE-COMMENTS 48979 . 49114)) (49116 50132 (COMPILE-FILE-SETF-SYMBOL-FUNCTION 49116 .
50132)) (50134 50925 (COMPILE-FILE-DEFINEQ 50134 . 50925)) (50927 51935 (COMPILE-FILE-DEFCONSTANT
50927 . 51935)) (51937 53854 (COMPILE-FILE-DECLARE\: 51937 . 53854)) (53856 54795 (
COMPILE-FILE-DEFINE-FILE-INFO 53856 . 54795)) (54797 55041 (COMPILE-FILE-PACKAGE-FORM 54797 . 55041))
(55043 57762 (COMPILE-FILE-PROCLAMATION 55043 . 57762)) (57764 59175 (COMPILE-FILE-COMPILER-LET 57764
. 59175)) (59177 59857 (COMPILE-FILE-MACROLET 59177 . 59857)) (59859 60849 (COMPILE-FILE-DEFINER
59859 . 60849)) (60851 61779 (COMPILE-FILE-NAMED-PROGN 60851 . 61779)) (61781 62431 (
COMPILE-FILE-OUTSTANDING-LOOSE-FORMS 61781 . 62431)) (62433 62575 (COMPILE-FILE-LOOSE-FORM 62433 .
62575)) (62577 62896 (COMPILE-FILE-PROCESS-FUNCTION 62577 . 62896)) (62898 63575 (CRACK-DEFMACRO 62898
. 63575)) (63577 63860 (ESTABLISH-MACRO-IN-COMPILER 63577 . 63860)) (64554 66781 (
COMPILE-SCAN-DECLARE\: 64554 . 66781)) (66783 67145 (COMPILE-SCAN-DEFINE-FILE-INFO 66783 . 67145)) (
67147 68061 (COMPILE-SCAN-MACROLET 67147 . 68061)) (68063 68698 (COMPILE-SCAN-DEFINER 68063 . 68698))
(68700 68833 (COMPILE-SCAN-LOOSE-FORM 68700 . 68833)) (68835 68909 (
COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS 68835 . 68909)) (68911 69359 (MERGE-FIRST-FORMS 68911 . 69359)) (
69484 71735 (COMPILE 69484 . 71735)) (71737 71990 (COMPILE-DEFINER 71737 . 71990)) (71992 73031 (
COMPILE-FORM 71992 . 73031)) (73033 73905 (RAW-COMPILE 73033 . 73905)) (73907 75006 (
COMPILE-DEFINER-DEFINER 73907 . 75006)) (75008 75846 (COMPILE-DEFINER-NAMED-PROGN 75008 . 75846)) (
75848 76683 (COMPILE-DEFINER-PROCESS-FUNCTION 75848 . 76683)) (76685 77639 (
COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS 76685 . 77639)))))
IL:STOP

BIN
sources/XCLC-TOP-LEVEL.DFASL
View File

Binary file not shown.