github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-03-29 03:16:04 +00:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into nhb-fix-ethereventfn

Browse Source 
Resolves conflict for
	internal/loadups/LOADUP-LISP
	internal/loadups/LOADUP-LISP.LCOM
from adding call to (RESTART.ETHER) at end of loadup.
This commit is contained in:
Nick Briggs
2026-03-26 18:39:51 -07:00
parent d79f1ae819 13eb940538
commit c160b0af15
1054 changed files with 13406 additions and 105977 deletions
Download Patch File Download Diff File Expand all files Collapse all files

46
sources/ADIR
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "15-Oct-2025 15:20:48" {WMEDLEY}<sources>ADIR.;62 70135
(FILECREATED " 5-Feb-2026 10:27:45" {WMEDLEY}<sources>ADIR.;67 70247
:EDIT-BY rmk
:CHANGES-TO (MACROS \UPF.EXTRACT)
:CHANGES-TO (FNS INTERPRET.REM.CM)
:PREVIOUS-DATE " 6-Feb-2025 17:48:54" {WMEDLEY}<sources>ADIR.;61)
:PREVIOUS-DATE " 1-Feb-2026 13:17:10" {WMEDLEY}<sources>ADIR.;66)
(PRETTYCOMPRINT ADIRCOMS)
@@ -1179,7 +1179,8 @@
HERALDSTRING])
(INTERPRET.REM.CM
[LAMBDA (RETFLG) (* ; "Edited 15-Mar-2021 12:27 by larry")
[LAMBDA (RETFLG) (* ; "Edited 1-Feb-2026 17:49 by rmk")
(* ; "Edited 15-Mar-2021 12:27 by larry")
(DECLARE (GLOBALVARS STARTUPFORM))
(* ;;; "Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote. If it's a string, it will be unread,, else the form will be evaluated at the next prompt. For use in INIT.LISP, among others. If RETFLG is true, the expression read is simply returned")
@@ -1187,23 +1188,22 @@
(PROG ([FILE (INFILEP (PACKFILENAME 'HOST '{DSK} 'BODY (UNIX-GETENV "LDEREMCM"]
COM)
(OR FILE (RETURN))
(SETQ FILE (OPENSTREAM FILE 'INPUT))
[SETQ FILE (OPENSTREAM FILE 'INPUT 'OLD '((:EXTERNAL-FORMAT :UTF-8]
(COND
[[AND (IGREATERP (GETFILEINFO FILE 'LENGTH)
([AND (IGREATERP (GETFILEINFO FILE 'LENGTH)
0)
(EQ (SKIPSEPRS FILE T)
'%")
(SETQ COM (CAR (NLSETQ (READ FILE T]
(CLOSEF FILE)
(COND
(RETFLG (* ; "Save it to return"))
(T (* ; "Unread a string")
(CL:UNLESS RETFLG (* ;
 "Save it to return; otherwise unread a string")
(* ;
 "RMK: Replace CR and LF by space to avoid EOL convention issues")
(for I from 1 to (NCHARS COM) when (FMEMB (NTHCHARCODE COM I)
(CHARCODE (CR LF EOL)))
do (RPLCHARCODE COM I (CHARCODE EOL)))
(BKSYSBUF COM]
(for I from 1 to (NCHARS COM) when (FMEMB (NTHCHARCODE COM I)
(CHARCODE (CR LF EOL)))
do (RPLCHARCODE COM I (CHARCODE EOL)))
(BKSYSBUF COM)))
(T (CLOSEF FILE)))
(RETURN (COND
(RETFLG COM)
@@ -1282,14 +1282,14 @@
(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3170 15997 (DELFILE 3180 . 3341) (FULLNAME 3343 . 3710) (INFILE 3712 . 3971) (INFILEP
3973 . 4108) (IOFILE 4110 . 4361) (OPENFILE 4363 . 4666) (OPENSTREAM 4668 . 9008) (OUTFILE 9010 . 9272
) (OUTFILEP 9274 . 9410) (RENAMEFILE 9412 . 9718) (SIMPLE.FINDFILE 9720 . 10130) (VMEMSIZE 10132 .
10299) (\COPYSYS 10301 . 14592) (\FLUSHVM 14594 . 15666) (\LOGOUT0 15668 . 15995)) (16496 41156 (
UNPACKFILENAME.STRING 16506 . 38342) (\UPF.DIRECTORY 38344 . 41154)) (42741 45047 (UNPACKFILENAME
42751 . 42937) (LASTCHPOS 42939 . 43633) (FILENAMEFIELD 43635 . 43929) (FILENAMEFIELD.STRING 43931 .
44335) (PACKFILENAME 44337 . 44680) (PACKFILENAME.STRING 44682 . 45045)) (59517 60430 (
FILEDIRCASEARRAY 59527 . 60428)) (60597 67894 (LOGOUT 60607 . 61652) (MAKESYS 61654 . 63283) (SYSOUT
63285 . 64837) (SAVEVM 64839 . 65639) (HERALD 65641 . 65801) (INTERPRET.REM.CM 65803 . 67517) (
\USEREVENT 67519 . 67892)) (68076 69803 (USERNAME 68086 . 69042) (SETUSERNAME 69044 . 69801)))))
(FILEMAP (NIL (3171 15998 (DELFILE 3181 . 3342) (FULLNAME 3344 . 3711) (INFILE 3713 . 3972) (INFILEP
3974 . 4109) (IOFILE 4111 . 4362) (OPENFILE 4364 . 4667) (OPENSTREAM 4669 . 9009) (OUTFILE 9011 . 9273
) (OUTFILEP 9275 . 9411) (RENAMEFILE 9413 . 9719) (SIMPLE.FINDFILE 9721 . 10131) (VMEMSIZE 10133 .
10300) (\COPYSYS 10302 . 14593) (\FLUSHVM 14595 . 15667) (\LOGOUT0 15669 . 15996)) (16497 41157 (
UNPACKFILENAME.STRING 16507 . 38343) (\UPF.DIRECTORY 38345 . 41155)) (42742 45048 (UNPACKFILENAME
42752 . 42938) (LASTCHPOS 42940 . 43634) (FILENAMEFIELD 43636 . 43930) (FILENAMEFIELD.STRING 43932 .
44336) (PACKFILENAME 44338 . 44681) (PACKFILENAME.STRING 44683 . 45046)) (59518 60431 (
FILEDIRCASEARRAY 59528 . 60429)) (60598 68006 (LOGOUT 60608 . 61653) (MAKESYS 61655 . 63284) (SYSOUT
63286 . 64838) (SAVEVM 64840 . 65640) (HERALD 65642 . 65802) (INTERPRET.REM.CM 65804 . 67629) (
\USEREVENT 67631 . 68004)) (68188 69915 (USERNAME 68198 . 69154) (SETUSERNAME 69156 . 69913)))))
STOP

BIN
sources/ADIR.LCOM
View File

Binary file not shown.

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.

80
sources/ATERM
View File

@@ -1,16 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "20-Jul-2022 17:05:17" {DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>ATERM.;5 57463
(FILECREATED " 9-Feb-2026 15:49:51" {WMEDLEY}<sources>ATERM.;7 56918
:CHANGES-TO (FNS \CHDEL1)
:EDIT-BY rmk
:PREVIOUS-DATE "19-Jul-2022 22:49:20"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>ATERM.;4)
:CHANGES-TO (FNS \CREATELINEBUFFER)
:PREVIOUS-DATE "20-Jul-2022 17:05:17" {WMEDLEY}<sources>ATERM.;5)
(* ; "
Copyright (c) 1982-1988, 1990, 2021 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT ATERMCOMS)
@@ -915,39 +912,33 @@ Copyright (c) 1982-1988, 1990, 2021 by Venue & Xerox Corporation.
(RETURN STREAM])
(\CREATELINEBUFFER
[LAMBDA (TERMINAL.STREAM) (* ; "Edited 29-Apr-2021 09:38 by rmk:")
[LAMBDA (TERMINAL.STREAM) (* ; "Edited 9-Feb-2026 15:49 by rmk")
(* ; "Edited 29-Apr-2021 09:38 by rmk:")
(* ;;
 "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).")
(* ;;
 "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).")
(LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((CHARSET T]
(LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((:EXTERNAL-FORMAT :THROUGH16]
(DEV (fetch (STREAM DEVICE) of STREAM))
EOFMETHOD)
(replace LINEBUFSTATE of STREAM with READING.LBS)
(replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM
\KEYBOARD.STREAM))
(replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM \KEYBOARD.STREAM))
(replace USERCLOSEABLE of STREAM with NIL)
(replace USERVISIBLE of STREAM with NIL)
(* ;
 "Other linebuffer fields default properly")
(replace USERVISIBLE of STREAM with NIL) (* ;
 "Other linebuffer fields default properly")
[replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM)
(CL:FUNCALL \RefillBufferFn]
(CL:FUNCALL \RefillBufferFn]
(replace (STREAM EOLCONVENTION) of STREAM with CR.EOLC)
(* ;
 "RMK: Terminal is CR, even if stream default is LF")
(if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of
TERMINAL.STREAM
))
'NILL))
(* ;
 "RMK: Terminal is CR, even if stream default is LF")
(if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of TERMINAL.STREAM))
'NILL))
then
(* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.")
(* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.")
(replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE
'FDEV DEV)))
(* ;
 "Copy the basic linebuffer device")
(replace (FDEV EOFP) of DEV with EOFMETHOD))
(replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE 'FDEV DEV)))
(* ; "Copy the basic linebuffer device")
(replace (FDEV EOFP) of DEV with EOFMETHOD))
STREAM])
(\LINEBUF.READP
@@ -1142,20 +1133,19 @@ Copyright (c) 1982-1988, 1990, 2021 by Venue & Xerox Corporation.
(ADDTOVAR LAMA VIDEOCOLOR TERMINAL-OUTPUT TERMINAL-INPUT)
)
(PUTPROPS ATERM COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2982 32059 (BKLINBUF 2992 . 3467) (CLEARBUF 3469 . 4801) (LINBUF 4803 . 4989) (
PAGEFULLFN 4991 . 6472) (SETLINELENGTH 6474 . 6670) (SYSBUF 6672 . 6858) (TERMCHARWIDTH 6860 . 7277) (
TERMINAL-INPUT 7279 . 7847) (TERMINAL-OUTPUT 7849 . 8435) (\CHDEL1 8437 . 8826) (\CLOSELINE 8828 .
9117) (\DECPARENCOUNT 9119 . 10702) (\ECHOCHAR 10704 . 11396) (\FILLBUFFER 11398 . 24389) (
\FILLBUFFER.WORDSEPRP 24391 . 24636) (\FILLBUFFER.BACKUP 24638 . 24817) (\GETCHAR 24819 . 25208) (
\INCPARENCOUNT 25210 . 27822) (\RESETLINE 27824 . 28148) (\RESETTERMINAL 28150 . 28914) (\SAVELINEBUF
28916 . 30887) (\STOPSCROLL? 30889 . 32057)) (32262 36118 (\DSCCOUT 32272 . 35412) (\INITBCPLDISPLAY
35414 . 36116)) (36311 37561 (VIDEOCOLOR 36321 . 37559)) (38329 44183 (\PEEKREFILL 38339 . 42450) (
\READREFILL 42452 . 43046) (\RATOM/RSTRING-REFILL 43048 . 43626) (\READCREFILL 43628 . 44181)) (44184
46013 (DRIBBLE 44194 . 45795) (DRIBBLEFILE 45797 . 46011)) (46014 52689 (\SETUP.DEFAULT.LINEBUF 46024
. 48481) (\CREATELINEBUFFER 48483 . 50905) (\LINEBUF.READP 50907 . 51256) (\LINEBUF.EOFP 51258 .
51597) (\LINEBUF.PEEKBIN 51599 . 51806) (\OPENLINEBUF 51808 . 52687)) (52764 54003 (LINEBUFFER-EOFP
52774 . 53232) (LINEBUFFER-SKIPSEPRS 53234 . 54001)) (54360 54634 (\INTERMP 54370 . 54501) (\OUTTERMP
54503 . 54632)))))
(FILEMAP (NIL (2854 31931 (BKLINBUF 2864 . 3339) (CLEARBUF 3341 . 4673) (LINBUF 4675 . 4861) (
PAGEFULLFN 4863 . 6344) (SETLINELENGTH 6346 . 6542) (SYSBUF 6544 . 6730) (TERMCHARWIDTH 6732 . 7149) (
TERMINAL-INPUT 7151 . 7719) (TERMINAL-OUTPUT 7721 . 8307) (\CHDEL1 8309 . 8698) (\CLOSELINE 8700 .
8989) (\DECPARENCOUNT 8991 . 10574) (\ECHOCHAR 10576 . 11268) (\FILLBUFFER 11270 . 24261) (
\FILLBUFFER.WORDSEPRP 24263 . 24508) (\FILLBUFFER.BACKUP 24510 . 24689) (\GETCHAR 24691 . 25080) (
\INCPARENCOUNT 25082 . 27694) (\RESETLINE 27696 . 28020) (\RESETTERMINAL 28022 . 28786) (\SAVELINEBUF
28788 . 30759) (\STOPSCROLL? 30761 . 31929)) (32134 35990 (\DSCCOUT 32144 . 35284) (\INITBCPLDISPLAY
35286 . 35988)) (36183 37433 (VIDEOCOLOR 36193 . 37431)) (38201 44055 (\PEEKREFILL 38211 . 42322) (
\READREFILL 42324 . 42918) (\RATOM/RSTRING-REFILL 42920 . 43498) (\READCREFILL 43500 . 44053)) (44056
45885 (DRIBBLE 44066 . 45667) (DRIBBLEFILE 45669 . 45883)) (45886 52246 (\SETUP.DEFAULT.LINEBUF 45896
. 48353) (\CREATELINEBUFFER 48355 . 50462) (\LINEBUF.READP 50464 . 50813) (\LINEBUF.EOFP 50815 .
51154) (\LINEBUF.PEEKBIN 51156 . 51363) (\OPENLINEBUF 51365 . 52244)) (52321 53560 (LINEBUFFER-EOFP
52331 . 52789) (LINEBUFFER-SKIPSEPRS 52791 . 53558)) (53917 54191 (\INTERMP 53927 . 54058) (\OUTTERMP
54060 . 54189)))))
STOP

BIN
sources/ATERM.LCOM
View File

Binary file not shown.

383
sources/BOOTSTRAP
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 "23-Apr-2025 23:39:10" {WMEDLEY}<sources>BOOTSTRAP.;61 47417
(FILECREATED " 2-Mar-2026 12:03:05" {WMEDLEY}<sources>BOOTSTRAP.;71 47856
:EDIT-BY rmk
:CHANGES-TO (FNS PRINT-READER-ENVIRONMENT \DO-DEFINE-FILE-INFO)
:CHANGES-TO (FNS READ-READER-ENVIRONMENT)
:PREVIOUS-DATE "27-Sep-2021 10:25:31" {WMEDLEY}<sources>BOOTSTRAP.;59)
:PREVIOUS-DATE "25-Feb-2026 15:03:24" {WMEDLEY}<sources>BOOTSTRAP.;69)
(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,73 +800,82 @@
(TERPRI STREAM)))])
(READ-READER-ENVIRONMENT
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 26-Sep-2021 23:31 by rmk:")
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 2-Mar-2026 12:03 by rmk")
(* ; "Edited 1-Mar-2026 10:49 by rmk")
(* ; "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
(if (\GETSTREAM STREAM 'INPUT T)
then (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*
)))
(DECLARE (SPECVARS *READTABLE*))
(SELCHARQ (SKIPSEPRCODES STREAM)
(";" (* ; "Assume it's a common lisp file")
(\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
)))
(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
*COMMON-LISP-READ-ENVIRONMENT*
))
*COMMON-LISP-READ-ENVIRONMENT*)
("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
))
*COMMON-LISP-READ-ENVIRONMENT*)
("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
*DEFINE-FILE-INFO-ENV*
)) (* ;
 "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
))(* ;
 "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
(* ;;
 "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 ARGS (CL:READ-DELIMITED-LIST (CHARCODE ")")
STREAM))
(SETQ ENV (\DO-DEFINE-FILE-INFO STREAM ARGS))
else (SETFILEPTR STREAM START))
[SETQ ENV (\DO-DEFINE-FILE-INFO STREAM (SETQ ARGS
(CL:READ-DELIMITED-LIST
(CHARCODE ")")
STREAM]
ELSE (* ; "Hope we are RANDACCESSP")
(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))
ENV)))
DEFAULTENV])
(CL:IF (AND RETURNFORM ARGS)
(CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS))
ENV)))
DEFAULTENV))
else (CL:WITH-OPEN-FILE (STRM (OR (FINDFILE STREAM T)
STREAM)
:DIRECTION :INPUT)
(READ-READER-ENVIRONMENT STRM DEFAULTENV RETURNFORM])
(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 +978,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 (4595 14267 (GETPROP 4605 . 5177) (SETATOMVAL 5179 . 5308) (RPAQQ 5310 . 5363) (RPAQ
5365 . 5677) (RPAQ? 5679 . 6049) (MOVD 6051 . 7915) (MOVD? 7917 . 8347) (SELECTQ 8349 . 8536) (
SELECTQ1 8538 . 8880) (NCONC1 8882 . 9078) (PUTPROP 9080 . 10564) (PROPNAMES 10566 . 10757) (ADDPROP
10759 . 12822) (REMPROP 12824 . 13678) (MEMB 13680 . 13939) (CLOSEF? 13941 . 14265)) (14340 34317 (
LOAD 14350 . 15519) (\LOAD-STREAM 15521 . 28008) (FILECREATED 28010 . 29428) (FILECREATED1 29430 .
30538) (PRETTYCOMPRINT 30540 . 31025) (BOOTSTRAP-NAMEFIELD 31027 . 31987) (PUTPROPS 31989 . 32357) (
DECLARE%: 32359 . 32491) (DECLARE%:1 32493 . 33365) (ROOTFILENAME 33367 . 34315)) (34355 45802 (
DEFINE-FILE-INFO 34365 . 34800) (\DO-DEFINE-FILE-INFO 34802 . 38945) (PRINT-READER-ENVIRONMENT 38947
. 40699) (READ-READER-ENVIRONMENT 40701 . 44368) (MAKE-DEFINE-FILE-INFO-ENV 44370 . 45800)))))
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.

55
sources/COREIO
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 "11-Sep-2025 16:49:07" {WMEDLEY}<sources>COREIO.;18 56903
(FILECREATED "28-Feb-2026 12:09:38" {WMEDLEY}<sources>COREIO.;20 57201
:EDIT-BY rmk
:CHANGES-TO (FNS \CORE.DIRECTORYNAMEP)
:PREVIOUS-DATE " 5-Jun-2022 00:14:07" {WMEDLEY}<sources>COREIO.;17)
:PREVIOUS-DATE "11-Sep-2025 16:49:07" {WMEDLEY}<sources>COREIO.;18)
(PRETTYCOMPRINT COREIOCOMS)
@@ -89,6 +89,8 @@
(\CORE.DIRECTORYNAMEP
[LAMBDA (DIRNAME DEV)
(* ;; "Edited 28-Feb-2026 12:08 by rmk")
(* ;; "Edited 11-Sep-2025 16:48 by rmk")
(* ;; "Edited 18-Jan-2022 11:17 by rmk")
@@ -106,18 +108,21 @@
(* ;; "Returns NIL for a DIRNAME of just {CORE}, or {CORE}xxx. If the latter, then we want it to be a directory and not a file (assuming that xxx and xxx> can't both exist.")
[LET [(DIR (FILENAMEFIELD DIRNAME 'DIRECTORY]
(CL:WHEN DIR
(SETQ DIR (CONCAT DIR ">"))
(LET [(DIR (FILENAMEFIELD DIRNAME 'DIRECTORY]
(if DIR
then (SETQ DIR (CONCAT DIR ">"))
(* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)")
(* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)")
(FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY))
FIRST (CL:UNLESS (EQ DIRPOS 1)
(SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS)))
IN (CDR (FETCH COREDIRECTORY OF DEV))
WHEN (STRPOS DIRNAME (CAR ENTRY)
1 NIL T NIL FILEDIRCASEARRAY) DO (RETURN T)))])])
(FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY))
FIRST (CL:UNLESS (EQ DIRPOS 1)
(SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS)))
IN (CDR (FETCH COREDIRECTORY OF DEV))
WHEN (STRPOS DIRNAME (CAR ENTRY)
1 NIL T NIL FILEDIRCASEARRAY) DO (RETURN T))
else (* ;
 "Top level: does the device exist at al. The cd {CORE}case")
T)))])
(\CORE.FINDPAGE
[LAMBDA (STREAM PN) (* bvm%: "20-Apr-85 13:32")
@@ -997,16 +1002,16 @@
)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1572 46115 (\CORE.CLOSEFILE 1582 . 2355) (\CORE.DELETEFILE 2357 . 4343) (
\CORE.DIRECTORYNAMEP 4345 . 5838) (\CORE.FINDPAGE 5840 . 9069) (\CORE.GENERATEFILES 9071 . 11658) (
\CORE.NEXTFILEFN 11660 . 12159) (\CORE.FILEINFOFN 12161 . 12390) (\CORE.GETFILEHANDLE 12392 . 14546) (
\CORE.GETFILEINFO 14548 . 15511) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15513 . 17050) (\CORE.GETFILENAME
17052 . 19341) (\CORE.GETINFOBLOCK 19343 . 21966) (\CORE.NAMESCAN 21968 . 23515) (\CORE.NAMESEGMENT
23517 . 23954) (\CORE.OPENFILE 23956 . 27348) (\COREFILE.SETPARAMETERS 27350 . 29531) (
\CORE.PACKFILENAME 29533 . 29928) (\CORE.RELEASEPAGES 29930 . 30531) (\CORE.SETFILEPTR 30533 . 31632)
(\CORE.UPDATEOF 31634 . 33263) (\CORE.BACKFILEPTR 33265 . 35473) (\CORE.SETEOFPTR 35475 . 37344) (
\CORE.SETACCESSTIME 37346 . 37971) (\CORE.SETFILEINFO 37973 . 40275) (\CORE.GETNEXTBUFFER 40277 .
44233) (\CORE.UNPACKFILENAME 44235 . 46113)) (46116 49749 (COREDEVICE 46126 . 46297) (
\CREATECOREDEVICE 46299 . 49747)) (49750 52164 (\NODIRCOREFDEV 49760 . 50357) (\NODIRCORE.OPENFILE
50359 . 52162)))))
(FILEMAP (NIL (1572 46413 (\CORE.CLOSEFILE 1582 . 2355) (\CORE.DELETEFILE 2357 . 4343) (
\CORE.DIRECTORYNAMEP 4345 . 6136) (\CORE.FINDPAGE 6138 . 9367) (\CORE.GENERATEFILES 9369 . 11956) (
\CORE.NEXTFILEFN 11958 . 12457) (\CORE.FILEINFOFN 12459 . 12688) (\CORE.GETFILEHANDLE 12690 . 14844) (
\CORE.GETFILEINFO 14846 . 15809) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15811 . 17348) (\CORE.GETFILENAME
17350 . 19639) (\CORE.GETINFOBLOCK 19641 . 22264) (\CORE.NAMESCAN 22266 . 23813) (\CORE.NAMESEGMENT
23815 . 24252) (\CORE.OPENFILE 24254 . 27646) (\COREFILE.SETPARAMETERS 27648 . 29829) (
\CORE.PACKFILENAME 29831 . 30226) (\CORE.RELEASEPAGES 30228 . 30829) (\CORE.SETFILEPTR 30831 . 31930)
(\CORE.UPDATEOF 31932 . 33561) (\CORE.BACKFILEPTR 33563 . 35771) (\CORE.SETEOFPTR 35773 . 37642) (
\CORE.SETACCESSTIME 37644 . 38269) (\CORE.SETFILEINFO 38271 . 40573) (\CORE.GETNEXTBUFFER 40575 .
44531) (\CORE.UNPACKFILENAME 44533 . 46411)) (46414 50047 (COREDEVICE 46424 . 46595) (
\CREATECOREDEVICE 46597 . 50045)) (50048 52462 (\NODIRCOREFDEV 50058 . 50655) (\NODIRCORE.OPENFILE
50657 . 52460)))))
STOP

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

365
sources/EXTERNALFORMAT
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 "29-Jan-2026 21:09:02" {WMEDLEY}<sources>EXTERNALFORMAT.;92 39722
(FILECREATED "22-Feb-2026 12:29:38" {WMEDLEY}<sources>EXTERNALFORMAT.;124 45411
:EDIT-BY rmk
:CHANGES-TO (FNS \EXTERNALFORMAT)
:CHANGES-TO (VARS EXTERNALFORMATCOMS)
:PREVIOUS-DATE "24-Apr-2025 08:43:01" {WMEDLEY}<sources>EXTERNALFORMAT.;91)
:PREVIOUS-DATE "20-Feb-2026 09:18:35" {WMEDLEY}<sources>EXTERNALFORMAT.;123)
(PRETTYCOMPRINT EXTERNALFORMATCOMS)
@@ -19,8 +19,7 @@
(SYSRECORDS EXTERNALFORMAT)
(FNS \EXTERNALFORMAT MAKE-EXTERNALFORMAT \EXTERNALFORMAT.DEFPRINT)
(FNS \INSTALL.EXTERNALFORMAT \REMOVE.EXTERNALFORMAT FIND-FORMAT)
(FNS SYSTEM-EXTERNALFORMAT)
(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*)
(EXPORT (GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*))
(INITVARS (*EXTERNALFORMATS* NIL)
(*DEFAULT-EXTERNALFORMAT* :MCCS))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'EXTERNALFORMAT (FUNCTION
@@ -30,7 +29,8 @@
(* ;; "Generic functions not compiled open (originally on LLREAD)")
(FNS \OUTCHAR \INCCODE \BACKCCODE \BACKCCODE.EOLC \PEEKCCODE \PEEKCCODE.EOLC
\INCCODE.EOLC \FORMATBYTESTREAM \FORMATBYTESTRING \CHECKEOLC.CRLF)
\INCCODE.EOLC \FORMATBYTESTREAM \CHECKEOLC.CRLF)
(FNS MCCSTOFORMATBYTES FORMATBYTESTOMCCS)
(DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CHECKEOLC))
(RESOURCES \FORMATBYTESTRING.STREAM))
(INITRESOURCES \FORMATBYTESTRING.STREAM))
@@ -38,10 +38,12 @@
(FNS \NULLDEVICE \NULL.OPENFILE)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\NULLDEVICE]
(COMS
(* ;; "Also from FILEIO, but not clear that this is or ever has been used.")
(* ;; "Also from FILEIO.")
(FNS \CREATE.THROUGH.EXTERNALFORMAT \THROUGHIN \THROUGHBACKCCODE \THROUGHOUTCHARFN)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT])
(FNS \CREATE.THROUGH.EXTERNALFORMAT \CREATE.THROUGH16.EXTERNALFORMAT \THROUGHIN
\THROUGHBACKCCODE \THROUGHOUTCHARFN)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT)
(\CREATE.THROUGH16.EXTERNALFORMAT])
@@ -67,15 +69,18 @@
(EF1 POINTER) (* ;
 "Extra fields for use of particular formats. Possibly to hold standardized translation tables")
(EF2 POINTER)
(FORMATBYTESTRINGFN POINTER) (* ; "Translates an internal string into a string containing the bytes that represent that string in this format")
(MCCSTOFORMATBYTESFN POINTER) (* ; "Translates an MCCS string into a string containing the bytes that represent that string in this format")
(FORMATCHARSETFN POINTER) (* ;
 "If present, apply by \GENERIC.CHARSET")
))
(FORMATBYTESTOMCCSFN POINTER)) (* ;
 "Translates format bytes into a string containing the corresponding MCCS codes")
)
)
(/DECLAREDATATYPE 'EXTERNALFORMAT
'(FLAG (BITS 2)
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER)
'((EXTERNALFORMAT 0 (FLAGBITS . 0))
(EXTERNALFORMAT 0 (BITS . 17))
(EXTERNALFORMAT 0 (FLAGBITS . 48))
@@ -88,8 +93,9 @@
(EXTERNALFORMAT 12 POINTER)
(EXTERNALFORMAT 14 POINTER)
(EXTERNALFORMAT 16 POINTER)
(EXTERNALFORMAT 18 POINTER))
'20)
(EXTERNALFORMAT 18 POINTER)
(EXTERNALFORMAT 20 POINTER))
'22)
(* "END EXPORTED DEFINITIONS")
@@ -97,7 +103,8 @@
(/DECLAREDATATYPE 'EXTERNALFORMAT
'(FLAG (BITS 2)
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER)
'((EXTERNALFORMAT 0 (FLAGBITS . 0))
(EXTERNALFORMAT 0 (BITS . 17))
(EXTERNALFORMAT 0 (FLAGBITS . 48))
@@ -110,8 +117,9 @@
(EXTERNALFORMAT 12 POINTER)
(EXTERNALFORMAT 14 POINTER)
(EXTERNALFORMAT 16 POINTER)
(EXTERNALFORMAT 18 POINTER))
'20)
(EXTERNALFORMAT 18 POINTER)
(EXTERNALFORMAT 20 POINTER))
'22)
(ADDTOVAR SYSTEMRECLST
(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG)
@@ -125,8 +133,9 @@
(FORMATBYTESTREAMFN POINTER)
(EF1 POINTER)
(EF2 POINTER)
(FORMATBYTESTRINGFN POINTER)
(FORMATCHARSETFN POINTER)))
(MCCSTOFORMATBYTESFN POINTER)
(FORMATCHARSETFN POINTER)
(FORMATBYTESTOMCCSFN POINTER)))
)
(DEFINEQ
@@ -199,7 +208,10 @@
(MAKE-EXTERNALFORMAT
[LAMBDA (NAME INCCODEFN PEEKCCODEFN BACKCCODEFN OUTCHARFN FORMATBYTESTREAMFN EOL UNSTABLE
FORMATBYTESTRINGFN DEFAULT FORMATCHARSETFN) (* ; "Edited 8-Dec-2023 22:02 by rmk")
MCCSTOFORMATBYTESFN DEFAULT FORMATCHARSETFN FORMATBYTESTOMCCSFN)
(* ; "Edited 5-Feb-2026 14:26 by rmk")
(* ; "Edited 2-Feb-2026 23:04 by rmk")
(* ; "Edited 8-Dec-2023 22:02 by rmk")
(* ; "Edited 3-Jul-2022 00:35 by rmk")
(* ; "Edited 10-Sep-2021 19:47 by rmk:")
@@ -210,17 +222,13 @@
*DEFAULT-EXTERNALFORMAT*
DEFAULT)]
(CL:UNLESS INCCODEFN
(SETQ INCCODEFN (FETCH (EXTERNALFORMAT INCCODEFN)
DEF)))
(SETQ INCCODEFN (FETCH (EXTERNALFORMAT INCCODEFN) OF DEF)))
(CL:UNLESS PEEKCCODEFN
(SETQ PEEKCCODEFN (FETCH (EXTERNALFORMAT PEEKCCODEFN)
DEF)))
(SETQ PEEKCCODEFN (FETCH (EXTERNALFORMAT PEEKCCODEFN) OF DEF)))
(CL:UNLESS BACKCCODEFN
(SETQ BACKCCODEFN (FETCH (EXTERNALFORMAT BACKCCODEFN)
DEF)))
(SETQ BACKCCODEFN (FETCH (EXTERNALFORMAT BACKCCODEFN) OF DEF)))
(CL:UNLESS OUTCHARFN
(SETQ OUTCHARFN (FETCH (EXTERNALFORMAT OUTCHARFN)
DEF)))])
(SETQ OUTCHARFN (FETCH (EXTERNALFORMAT OUTCHARFN) OF DEF)))])
(SETQ EOL (SELECTC EOL
((LIST 'LF LF.EOLC)
LF.EOLC)
@@ -231,17 +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
FORMATBYTESTRINGFN _ FORMATBYTESTRINGFN
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")
@@ -255,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.")
@@ -264,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 .")
@@ -290,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
@@ -306,19 +312,14 @@
OF EF)))
(CL:UNLESS NOERROR (ERROR NAME "is not an external format"])
)
(DEFINEQ
(SYSTEM-EXTERNALFORMAT
[LAMBDA NIL (* ; "Edited 10-Oct-2022 11:55 by lmm")
(* ; "Edited 7-Jul-2022 10:41 by rmk")
(FOR X IN '("LC_CTYPE" "LC_ALL" "LANG") WHEN (STRPOS ".UTF-8" (UNIX-GETENV X))
DO (RETURN :UTF-8) FINALLY (RETURN :THROUGH])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*)
)
(* "END EXPORTED DEFINITIONS")
(RPAQ? *EXTERNALFORMATS* NIL)
(RPAQ? *DEFAULT-EXTERNALFORMAT* :MCCS)
@@ -524,28 +525,6 @@
(freplace (STREAM ENDOFSTREAMOP) of BYTESTREAM with (FUNCTION NILL)))
BYTESTREAM])
(\FORMATBYTESTRING
[LAMBDA (STREAM STRING) (* ; "Edited 19-Mar-2024 18:24 by rmk")
(* ; "Edited 10-Jul-2022 16:39 by rmk")
(* ; "Edited 22-Jun-2022 11:07 by rmk")
(* ; "Edited 18-Jun-2022 22:04 by rmk")
(WITH-RESOURCE \FORMATBYTESTRING.STREAM (\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(LET [FSTRING NBYTES (BYTESTRINGFN (FETCH (EXTERNALFORMAT FORMATBYTESTRINGFN)
OF (FETCH (STREAM EXTERNALFORMAT) OF STREAM]
(IF BYTESTRINGFN
THEN (CL:WHEN (SETQ FSTRING (APPLY* BYTESTRINGFN STREAM STRING
\FORMATBYTESTRING.STREAM))
(MKSTRING FSTRING))
ELSE (\FORMATBYTESTREAM STREAM \FORMATBYTESTRING.STREAM)
(FOR C INPNAME STRING DO (\OUTCHAR \FORMATBYTESTRING.STREAM C))
(SETQ NBYTES (\GETFILEPTR \FORMATBYTESTRING.STREAM))
(\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(SETQ FSTRING (ALLOCSTRING NBYTES))
(FOR I FROM 1 TO NBYTES DO (RPLCHARCODE FSTRING I (\BIN
\FORMATBYTESTRING.STREAM
)))
FSTRING])
(\CHECKEOLC.CRLF
[LAMBDA (STREAM PEEKBINFLG COUNTP EOLC) (* ; "Edited 6-Dec-2023 23:39 by rmk")
(* ; "Edited 17-Oct-2023 11:56 by rmk")
@@ -606,6 +585,66 @@
(CHARCODE CR]
CH])
)
(DEFINEQ
(MCCSTOFORMATBYTES
[LAMBDA (FORMAT MSTRING) (* ; "Edited 6-Feb-2026 18:12 by rmk")
(* ; "Edited 5-Feb-2026 10:24 by rmk")
(* ; "Edited 3-Feb-2026 11:06 by rmk")
(* ; "Edited 19-Mar-2024 18:24 by rmk")
(* ; "Edited 10-Jul-2022 16:39 by rmk")
(* ; "Edited 22-Jun-2022 11:07 by rmk")
(* ; "Edited 18-Jun-2022 22:04 by rmk")
(CL:WHEN MSTRING
(CL:UNLESS (type? EXTERNALFORMAT FORMAT)
(SETQ FORMAT (OR (if (type? STREAM FORMAT)
then (fetch (STREAM EXTERNALFORMAT) of FORMAT)
else (FIND-FORMAT FORMAT))
(\ILLEGAL.ARG FORMAT))))
(LET (FSTRING NBYTES (TOBYTESFN (fetch (EXTERNALFORMAT MCCSTOFORMATBYTESFN) of FORMAT)))
(if TOBYTESFN
then (CL:WHEN (SETQ FSTRING (APPLY* TOBYTESFN MSTRING))
(MKSTRING FSTRING))
else
(* ;;
 "No specific function, fake it by the outchar function. Maybe return NIL if UNSTABLE?")
(WITH-RESOURCE \FORMATBYTESTRING.STREAM (\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(STREAMPROP \FORMATBYTESTRING.STREAM :EXTERNAL-FORMAT FORMAT)
(for C inpname MSTRING do (\OUTCHAR \FORMATBYTESTRING.STREAM C))
(SETQ NBYTES (\GETFILEPTR \FORMATBYTESTRING.STREAM))
(\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(SETQ FSTRING (ALLOCSTRING NBYTES))
(for I from 1 to NBYTES do (RPLCHARCODE FSTRING I (\BIN
\FORMATBYTESTRING.STREAM
)))
FSTRING))))])
(FORMATBYTESTOMCCS
[LAMBDA (FORMAT FSTRING) (* ; "Edited 6-Feb-2026 18:13 by rmk")
(* ;; "Produces an MCCS string with characters that correspond to the format bytes in FSTRING according to FORMAT.")
(CL:WHEN FSTRING
(CL:UNLESS (type? EXTERNALFORMAT FORMAT)
(SETQ FORMAT (OR (if (type? STREAM FORMAT)
then (fetch (STREAM EXTERNALFORMAT) of FORMAT)
else (FIND-FORMAT FORMAT))
(\ILLEGAL.ARG FORMAT))))
(SETQ FSTRING (MKSTRING FSTRING)) (* ; "Should be thin, if bytes")
[LET ((TOMCCSFN (fetch (EXTERNALFORMAT FORMATBYTESTOMCCSFN) of FORMAT))
MSTRING)
(if TOMCCSFN
then (APPLY* TOMCCSFN FSTRING)
else
(* ;; "No specific function, fake it by bouting the FSTRING characters and reading them with \INCCODEFN. ENDOFSTREAMOP is NILL")
(WITH-RESOURCE \FORMATBYTESTRING.STREAM (\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(for B instring FSTRING do (\BOUT \FORMATBYTESTRING.STREAM B))
(\SETFILEPTR \FORMATBYTESTRING.STREAM 0)
(STREAMPROP \FORMATBYTESTRING.STREAM :EXTERNAL-FORMAT FORMAT)
(RSTRING \FORMATBYTESTRING.STREAM])])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
@@ -629,7 +668,9 @@
(DECLARE%: EVAL@COMPILE
[PUTDEF '\FORMATBYTESTRING.STREAM 'RESOURCES '(NEW (OPENSTREAM '{NODIRCORE} 'BOTH]
[PUTDEF '\FORMATBYTESTRING.STREAM 'RESOURCES '(NEW (OPENSTREAM '{NODIRCORE} 'BOTH)
NIL
'((ENDOFSTREAMOP NILL]
)
)
@@ -647,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
@@ -690,31 +731,82 @@
(* ;; "Also from FILEIO, but not clear that this is or ever has been used.")
(* ;; "Also from FILEIO.")
(DEFINEQ
(\CREATE.THROUGH.EXTERNALFORMAT
[LAMBDA NIL (* ; "Edited 24-Jul-2022 08:08 by rmk")
[LAMBDA NIL (* ; "Edited 9-Feb-2026 15:43 by rmk")
(* ; "Edited 5-Feb-2026 13:12 by rmk")
(* ; "Edited 24-Jul-2022 08:08 by rmk")
(* ; "Edited 23-Jun-2021 13:34 by rmk:")
(* ;;; "Create the :THROUGH external format. EOL is adjusted so that the .EOLC callers will not do any conversion.")
(MAKE-EXTERNALFORMAT :THROUGH (FUNCTION \THROUGHIN)
(MAKE-EXTERNALFORMAT :THROUGH [FUNCTION (LAMBDA (STREAM COUNTP)
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1))
(\BIN STREAM]
(FUNCTION \PEEKBIN)
(FUNCTION \THROUGHBACKCCODE)
(FUNCTION \THROUGHOUTCHARFN)
[FUNCTION (LAMBDA (STREAM COUNTP)
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN (\BACKFILEPTR STREAM)
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
T)]
[FUNCTION (LAMBDA (OUTSTREAM CHARCODE)
(CL:WHEN (> CHARCODE \MAXTHINCHAR)
(ERROR ":THROUGH external format can't represent 16 bit characters"))
(\BOUT OUTSTREAM CHARCODE]
NIL
(CL:IF (EQ (CHARCODE CR)
(CHARCODE EOL))
CR.EOLC
LF.EOLC)
NIL
(FUNCTION (LAMBDA (STREAM STRING)
(MKSTRING STRING])
(FUNCTION MKSTRING)
NIL NIL (FUNCTION MKSTRING])
(\CREATE.THROUGH16.EXTERNALFORMAT
[LAMBDA NIL (* ; "Edited 9-Feb-2026 15:47 by rmk")
(* ; "Edited 5-Feb-2026 13:12 by rmk")
(* ; "Edited 24-Jul-2022 08:08 by rmk")
(* ; "Edited 23-Jun-2021 13:34 by rmk:")
(* ;;; "Create the :THROUGH external format. EOL is adjusted so that the .EOLC callers will not do any conversion.")
(MAKE-EXTERNALFORMAT :THROUGH16 [FUNCTION (LAMBDA (STREAM COUNTP)
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 2))
(\WIN STREAM]
[FUNCTION (LAMBDA (STREAM NOERRORFLG)
(LET (BYTE1 BYTE2)
(CL:WHEN (SETQ BYTE1 (\PEEKBIN STREAM NOERRORFLG))
(\BIN STREAM)
(SETQ BYTE2 (\PEEKBIN STREAM NOERRORFLG))
(\BACKFILEPTR STREAM)
(CL:WHEN BYTE2
(LOGOR (LLSH BYTE1 8)
BYTE2)))]
[FUNCTION (LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:")
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN (\BACKFILEPTR STREAM)
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
(CL:WHEN (\BACKFILEPTR STREAM)
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -2))
T))]
[FUNCTION (LAMBDA (OUTSTREAM CHARCODE)
(\WOUT OUTSTREAM CHARCODE]
NIL
(CL:IF (EQ (CHARCODE CR)
(CHARCODE EOL))
CR.EOLC
LF.EOLC)
NIL
(FUNCTION MKSTRING)
NIL NIL (FUNCTION MKSTRING])
(\THROUGHIN
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:")
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:")
(* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.")
@@ -725,14 +817,14 @@
(\BIN STREAM])
(\THROUGHBACKCCODE
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:")
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:")
(DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN (\BACKFILEPTR STREAM)
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
T)])
(\THROUGHOUTCHARFN
[LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm")
[LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm")
(* ;;; "Encoder for THROUGH format.")
@@ -745,15 +837,18 @@
(DECLARE%: DONTEVAL@LOAD DOCOPY
(\CREATE.THROUGH.EXTERNALFORMAT)
(\CREATE.THROUGH16.EXTERNALFORMAT)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (6706 14360 (\EXTERNALFORMAT 6716 . 11315) (MAKE-EXTERNALFORMAT 11317 . 13887) (
\EXTERNALFORMAT.DEFPRINT 13889 . 14358)) (14361 17402 (\INSTALL.EXTERNALFORMAT 14371 . 15820) (
\REMOVE.EXTERNALFORMAT 15822 . 16653) (FIND-FORMAT 16655 . 17400)) (17403 17815 (SYSTEM-EXTERNALFORMAT
17413 . 17813)) (18164 34141 (\OUTCHAR 18174 . 19391) (\INCCODE 19393 . 20546) (\BACKCCODE 20548 .
22227) (\BACKCCODE.EOLC 22229 . 24419) (\PEEKCCODE 24421 . 24746) (\PEEKCCODE.EOLC 24748 . 25127) (
\INCCODE.EOLC 25129 . 26928) (\FORMATBYTESTREAM 26930 . 29374) (\FORMATBYTESTRING 29376 . 31076) (
\CHECKEOLC.CRLF 31078 . 34139)) (35423 37659 (\NULLDEVICE 35433 . 37335) (\NULL.OPENFILE 37337 . 37657
)) (37799 39626 (\CREATE.THROUGH.EXTERNALFORMAT 37809 . 38595) (\THROUGHIN 38597 . 39017) (
\THROUGHBACKCCODE 39019 . 39286) (\THROUGHOUTCHARFN 39288 . 39624)))))
(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.

192
sources/FILEIO
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Sep-2025 08:19:06" {WMEDLEY}<sources>FILEIO.;141 166968
(FILECREATED " 6-Feb-2026 23:22:00" {WMEDLEY}<sources>FILEIO.;142 166519
:EDIT-BY rmk
:CHANGES-TO (FNS COPYFILE COPYCHARS)
:CHANGES-TO (FNS DIRECTORYNAME)
:PREVIOUS-DATE "24-Apr-2025 22:16:47"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>FILEIO.;139)
:PREVIOUS-DATE "12-Sep-2025 08:19:06" {WMEDLEY}<sources>FILEIO.;141)
(PRETTYCOMPRINT FILEIOCOMS)
@@ -1986,68 +1985,63 @@ update the map")
\CONNECTED.DIRECTORY])
(DIRECTORYNAME
[LAMBDA (DIRNAME STRPTR CREATE?) (* ; "Edited 20-May-92 11:08 by jds")
[LAMBDA (DIRNAME STRPTR CREATE?) (* ; "Edited 6-Feb-2026 23:19 by rmk")
(* ; "Edited 20-May-92 11:08 by jds")
(* ;; "Returns connected directory name")
(* ;; "Returns connected directory name")
(AND (CL:PATHNAMEP DIRNAME)
(SETQ DIRNAME (CL:NAMESTRING DIRNAME)))
(SELECTQ (SYSTEMTYPE)
(VAX (GETDIRNAME))
(D (DECLARE (GLOBALVARS LOGINHOST/DIR))
[PROG (DN FDEV)
[SELECTQ DIRNAME
(T (* ; "Connected host/dir")
(SETQ DN \CONNECTED.DIRECTORY))
(NIL (SETQ DN (OR LOGINHOST/DIR '{DSK})))
(COND
[(AND [SETQ FDEV
(LET [(HOST (FILENAMEFIELD DIRNAME 'HOST]
(SELCHARQ (NTHCHARCODE DIRNAME 1)
(> (* ;
 "Remove leading > from a subdirectory spec.")
(SETQ DIRNAME (SUBSTRING DIRNAME 2)))
NIL)
(\GETDEVICEFROMHOSTNAME
(OR HOST (FILENAMEFIELD [SELCHARQ (NTHCHARCODE DIRNAME 1)
((< /)
(* ; "Whole directory, use it all.")
(SETQ DIRNAME
(PACKFILENAME.STRING
'DIRECTORY DIRNAME
'BODY \CONNECTED.DIRECTORY)))
(SELCHARQ (NTHCHARCODE DIRNAME
(NCHARS DIRNAME))
((> /)
(* ;
 "Remove any trailing > or / from a subdirectory spec.")
(SETQ DIRNAME
(PACKFILENAME.STRING
'SUBDIRECTORY
(SUBSTRING DIRNAME 1 -2
)
'DIRECTORY
\CONNECTED.DIRECTORY)))
(SETQ DIRNAME
(PACKFILENAME.STRING
'SUBDIRECTORY DIRNAME
'DIRECTORY
\CONNECTED.DIRECTORY]
'HOST]
(SETQ DN (FDEVOP 'DIRECTORYNAMEP FDEV DIRNAME FDEV CREATE?)))
(COND
((EQ DN T)
(SETQ DN (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME)
of FDEV)
'DIRECTORY DIRNAME]
(T (RETURN]
(RETURN (COND
((NOT STRPTR)
(MKSTRING DN))
((EQ STRPTR T)
(MKATOM DN))
(T (MKSTRING DN])
(HELP])
(DECLARE (GLOBALVARS LOGINHOST/DIR))
(CL:WHEN (CL:PATHNAMEP DIRNAME)
(SETQ DIRNAME (CL:NAMESTRING DIRNAME)))
(PROG (DN FDEV)
[SELECTQ DIRNAME
(T (* ; "Connected host/dir")
(SETQ DN \CONNECTED.DIRECTORY))
(NIL (SETQ DN (OR LOGINHOST/DIR '{DSK})))
(COND
[(AND [SETQ FDEV
(LET [(HOST (FILENAMEFIELD DIRNAME 'HOST]
(SELCHARQ (NTHCHARCODE DIRNAME 1)
(> (* ;
 "Remove leading > from a subdirectory spec.")
(SETQ DIRNAME (SUBSTRING DIRNAME 2)))
NIL)
(\GETDEVICEFROMHOSTNAME
(OR HOST (FILENAMEFIELD [SELCHARQ (NTHCHARCODE DIRNAME 1)
((< /)
(* ; "Whole directory, use it all.")
(SETQ DIRNAME (PACKFILENAME.STRING
'DIRECTORY DIRNAME
'BODY
\CONNECTED.DIRECTORY)))
(SELCHARQ (NTHCHARCODE DIRNAME
(NCHARS DIRNAME))
((> /)
(* ;
 "Remove any trailing > or / from a subdirectory spec.")
(SETQ DIRNAME
(PACKFILENAME.STRING
'SUBDIRECTORY
(SUBSTRING DIRNAME 1 -2)
'DIRECTORY
\CONNECTED.DIRECTORY)))
(SETQ DIRNAME (PACKFILENAME.STRING
'SUBDIRECTORY DIRNAME
'DIRECTORY
\CONNECTED.DIRECTORY]
'HOST]
(SETQ DN (FDEVOP 'DIRECTORYNAMEP FDEV DIRNAME FDEV CREATE?)))
(COND
((EQ DN T)
(SETQ DN (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME) of FDEV)
'DIRECTORY DIRNAME]
(T (RETURN]
(RETURN (COND
((NOT STRPTR)
(MKSTRING DN))
((EQ STRPTR T)
(MKATOM DN))
(T (MKSTRING DN])
(DIRECTORYNAMEP
[LAMBDA (DIRNAME HOSTNAME) (* bvm%: "18-Oct-85 14:38")
@@ -3167,39 +3161,39 @@ update the map")
(ADDTOVAR LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (27752 31868 (STREAMPROP 27762 . 28196) (GETSTREAMPROP 28198 . 28947) (PUTSTREAMPROP
28949 . 31716) (STREAMP 31718 . 31866)) (31911 35290 (\DEFPRINT.BY.NAME 31921 . 33073) (
\STREAM.DEFPRINT 33075 . 34983) (\FDEV.DEFPRINT 34985 . 35288)) (35548 40589 (\GETACCESS 35558 . 36012
) (\SETACCESS 36014 . 40587)) (60815 66784 (\DEFINEDEVICE 60825 . 63141) (\GETDEVICEFROMNAME 63143 .
63616) (\GETDEVICEFROMHOSTNAME 63618 . 64662) (\REMOVEDEVICE 64664 . 65787) (\REMOVEDEVICE.NAMES 65789
. 66782)) (66824 94555 (\CLOSEFILE 66834 . 67659) (\DELETEFILE 67661 . 67955) (\DEVICEEVENT 67957 .
69727) (\GENERATEFILES 69729 . 70676) (\GENERATENEXTFILE 70678 . 71329) (\GENERATEFILEINFO 71331 .
71792) (\GETFILENAME 71794 . 72183) (\GENERIC.OUTFILEP 72185 . 72655) (\OPENFILE 72657 . 75235) (
\DO.PARAMS.AT.OPEN 75237 . 79433) (\RENAMEFILE 79435 . 80391) (\REVALIDATEFILE 80393 . 82995) (
\PAGED.REVALIDATEFILELST 82997 . 84555) (\PAGED.REVALIDATEFILES 84557 . 86276) (\PAGED.REVALIDATEFILE
86278 . 88561) (\BUFFERED.REVALIDATEFILE 88563 . 90849) (\BUFFERED.REVALIDATEFILELST 90851 . 92035) (
\PRINT-REVALIDATION-RESULT 92037 . 92879) (\TRUNCATEFILE 92881 . 93272) (\FILE-CONFLICT 93274 . 94553)
) (94591 99254 (\GENERATENOFILES 94601 . 96697) (\NULLFILEGENERATOR 96699 . 96943) (\NOFILESNEXTFILEFN
96945 . 98936) (\NOFILESINFOFN 98938 . 99252)) (99373 101281 (\FILE.NOT.OPEN 99383 . 99896) (
\FILE.WONT.OPEN 99898 . 100226) (\ILLEGAL.DEVICEOP 100228 . 100510) (\IS.NOT.RANDACCESSP 100512 .
100958) (\STREAM.NOT.OPEN 100960 . 101279)) (101416 103714 (\FDEVINSTANCE 101426 . 103712)) (104916
112290 (CNDIR 104926 . 106231) (DIRECTORYNAME 106233 . 110416) (DIRECTORYNAMEP 110418 . 111034) (
HOSTNAMEP 111036 . 111843) (\ADD.CONNECTED.DIR 111845 . 112288)) (112335 141282 (\BACKFILEPTR 112345
. 112533) (\BACKPEEKBIN 112535 . 112896) (\BACKBIN 112898 . 113249) (BIN 113251 . 113468) (\BIN
113470 . 113747) (\BINS 113749 . 114035) (BOUT 114037 . 114399) (\BOUT 114401 . 114716) (\BOUTS 114718
. 115029) (COPYBYTES 115031 . 118363) (COPYCHARS 118365 . 122163) (COPYFILE 122165 . 123525) (
\COPYOPENFILE 123527 . 126726) (\INFER.FILE.TYPE 126728 . 127682) (EOFP 127684 . 127981) (FORCEOUTPUT
127983 . 128230) (\FLUSH.OPEN.STREAMS 128232 . 128588) (CHARSET 128590 . 129949) (ACCESS-CHARSET
129951 . 130588) (GETEOFPTR 130590 . 130840) (GETFILEINFO 130842 . 134035) (\TYPE.FROM.FILETYPE 134037
. 134507) (\FILETYPE.FROM.TYPE 134509 . 134688) (GETFILEPTR 134690 . 134942) (SETFILEINFO 134944 .
139181) (SETFILEPTR 139183 . 140902) (BOUT16 140904 . 141089) (BIN16 141091 . 141280)) (141385 148565
(\GENERIC.BINS 141395 . 141675) (\GENERIC.BOUTS 141677 . 141942) (\GENERIC.RENAMEFILE 141944 . 144192)
(\GENERIC.OPENP 144194 . 145509) (\GENERIC.READP 145511 . 146663) (\GENERIC.CHARSET 146665 . 148563))
(148566 148905 (\MAP-OPEN-STREAMS 148576 . 148903)) (150760 152840 (\EOF.ACTION 150770 . 151021) (
\EOSERROR 151023 . 151216) (\GETEOFPTR 151218 . 151400) (\INCFILEPTR 151402 . 151752) (\PEEKBIN 151754
. 151945) (\SETCLOSEDFILELENGTH 151947 . 152281) (\SETEOFPTR 152283 . 152471) (\SETFILEPTR 152473 .
152838)) (152841 153383 (\FIXPOUT 152851 . 153151) (\FIXPIN 153153 . 153381)) (153384 153950 (\BOUTEOL
153394 . 153948)) (156846 166710 (\BUFFERED.BIN 156856 . 157708) (\BUFFERED.PEEKBIN 157710 . 158492)
(\BUFFERED.BOUT 158494 . 159354) (\BUFFERED.BINS 159356 . 163041) (\BUFFERED.BOUTS 163043 . 164844) (
\BUFFERED.COPYBYTES 164846 . 166708)))))
(FILEMAP (NIL (27706 31822 (STREAMPROP 27716 . 28150) (GETSTREAMPROP 28152 . 28901) (PUTSTREAMPROP
28903 . 31670) (STREAMP 31672 . 31820)) (31865 35244 (\DEFPRINT.BY.NAME 31875 . 33027) (
\STREAM.DEFPRINT 33029 . 34937) (\FDEV.DEFPRINT 34939 . 35242)) (35502 40543 (\GETACCESS 35512 . 35966
) (\SETACCESS 35968 . 40541)) (60769 66738 (\DEFINEDEVICE 60779 . 63095) (\GETDEVICEFROMNAME 63097 .
63570) (\GETDEVICEFROMHOSTNAME 63572 . 64616) (\REMOVEDEVICE 64618 . 65741) (\REMOVEDEVICE.NAMES 65743
. 66736)) (66778 94509 (\CLOSEFILE 66788 . 67613) (\DELETEFILE 67615 . 67909) (\DEVICEEVENT 67911 .
69681) (\GENERATEFILES 69683 . 70630) (\GENERATENEXTFILE 70632 . 71283) (\GENERATEFILEINFO 71285 .
71746) (\GETFILENAME 71748 . 72137) (\GENERIC.OUTFILEP 72139 . 72609) (\OPENFILE 72611 . 75189) (
\DO.PARAMS.AT.OPEN 75191 . 79387) (\RENAMEFILE 79389 . 80345) (\REVALIDATEFILE 80347 . 82949) (
\PAGED.REVALIDATEFILELST 82951 . 84509) (\PAGED.REVALIDATEFILES 84511 . 86230) (\PAGED.REVALIDATEFILE
86232 . 88515) (\BUFFERED.REVALIDATEFILE 88517 . 90803) (\BUFFERED.REVALIDATEFILELST 90805 . 91989) (
\PRINT-REVALIDATION-RESULT 91991 . 92833) (\TRUNCATEFILE 92835 . 93226) (\FILE-CONFLICT 93228 . 94507)
) (94545 99208 (\GENERATENOFILES 94555 . 96651) (\NULLFILEGENERATOR 96653 . 96897) (\NOFILESNEXTFILEFN
96899 . 98890) (\NOFILESINFOFN 98892 . 99206)) (99327 101235 (\FILE.NOT.OPEN 99337 . 99850) (
\FILE.WONT.OPEN 99852 . 100180) (\ILLEGAL.DEVICEOP 100182 . 100464) (\IS.NOT.RANDACCESSP 100466 .
100912) (\STREAM.NOT.OPEN 100914 . 101233)) (101370 103668 (\FDEVINSTANCE 101380 . 103666)) (104870
111841 (CNDIR 104880 . 106185) (DIRECTORYNAME 106187 . 109967) (DIRECTORYNAMEP 109969 . 110585) (
HOSTNAMEP 110587 . 111394) (\ADD.CONNECTED.DIR 111396 . 111839)) (111886 140833 (\BACKFILEPTR 111896
. 112084) (\BACKPEEKBIN 112086 . 112447) (\BACKBIN 112449 . 112800) (BIN 112802 . 113019) (\BIN
113021 . 113298) (\BINS 113300 . 113586) (BOUT 113588 . 113950) (\BOUT 113952 . 114267) (\BOUTS 114269
. 114580) (COPYBYTES 114582 . 117914) (COPYCHARS 117916 . 121714) (COPYFILE 121716 . 123076) (
\COPYOPENFILE 123078 . 126277) (\INFER.FILE.TYPE 126279 . 127233) (EOFP 127235 . 127532) (FORCEOUTPUT
127534 . 127781) (\FLUSH.OPEN.STREAMS 127783 . 128139) (CHARSET 128141 . 129500) (ACCESS-CHARSET
129502 . 130139) (GETEOFPTR 130141 . 130391) (GETFILEINFO 130393 . 133586) (\TYPE.FROM.FILETYPE 133588
. 134058) (\FILETYPE.FROM.TYPE 134060 . 134239) (GETFILEPTR 134241 . 134493) (SETFILEINFO 134495 .
138732) (SETFILEPTR 138734 . 140453) (BOUT16 140455 . 140640) (BIN16 140642 . 140831)) (140936 148116
(\GENERIC.BINS 140946 . 141226) (\GENERIC.BOUTS 141228 . 141493) (\GENERIC.RENAMEFILE 141495 . 143743)
(\GENERIC.OPENP 143745 . 145060) (\GENERIC.READP 145062 . 146214) (\GENERIC.CHARSET 146216 . 148114))
(148117 148456 (\MAP-OPEN-STREAMS 148127 . 148454)) (150311 152391 (\EOF.ACTION 150321 . 150572) (
\EOSERROR 150574 . 150767) (\GETEOFPTR 150769 . 150951) (\INCFILEPTR 150953 . 151303) (\PEEKBIN 151305
. 151496) (\SETCLOSEDFILELENGTH 151498 . 151832) (\SETEOFPTR 151834 . 152022) (\SETFILEPTR 152024 .
152389)) (152392 152934 (\FIXPOUT 152402 . 152702) (\FIXPIN 152704 . 152932)) (152935 153501 (\BOUTEOL
152945 . 153499)) (156397 166261 (\BUFFERED.BIN 156407 . 157259) (\BUFFERED.PEEKBIN 157261 . 158043)
(\BUFFERED.BOUT 158045 . 158905) (\BUFFERED.BINS 158907 . 162592) (\BUFFERED.BOUTS 162594 . 164395) (
\BUFFERED.COPYBYTES 164397 . 166259)))))
STOP

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

623
sources/FONT
View File

File diff suppressed because it is too large Load Diff

BIN
sources/FONT.LCOM
View File

Binary file not shown.

1485
sources/IOCHAR
View File

File diff suppressed because it is too large Load Diff

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

140
sources/LLSUBRS
View File

@@ -1,15 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "13-Sep-2021 17:12:03" {DSK}<Users>briggs>Projects>medley>sources>LLSUBRS.;8 27017
changes to%: (VARS \INITSUBRS)
(FNS WRITECALLSUBRS)
(FILECREATED " 5-Feb-2026 23:25:59" {WMEDLEY}<sources>LLSUBRS.;18 26279
previous date%: "13-Sep-2021 16:07:08" {DSK}<VAR>TMP>LLSUBRS.;1)
:EDIT-BY rmk
:CHANGES-TO (FNS UNIX-GETENV UNIX-USERNAME UNIX-FULLNAME UNIX-GETPARM)
:PREVIOUS-DATE " 5-Feb-2026 18:13:25" {WMEDLEY}<sources>LLSUBRS.;11)
(* ; "
Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT LLSUBRSCOMS)
@@ -94,9 +92,9 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
,@ARGS])
(DEFOPTIMIZER MISCN (NAME &REST ARGS)
`((OPCODES MISCN ,(MISCN-NUMBER NAME)
,(LENGTH ARGS))
,@ARGS))
`((OPCODES MISCN ,(MISCN-NUMBER NAME)
,(LENGTH ARGS))
,@ARGS))
(DEFINEQ
(MISCN-NUMBER
@@ -190,25 +188,15 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
(SETQ \MISCN-TABLE BASE])
)
(PUTPROPS MISCN ARGNAMES (NAME &REST ARGS))
(PUTPROPS MISCN ARGNAMES ("NAME" &REST "ARGS"))
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD MISCN-UFN-SPEC (
(* ;;
 "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.")
NAME (* ;
 "Name of the MISCN, for the MISCN macro's use.")
INDEX (* ; "Sub-opcode index.")
UFN-NAME (* ; "Name of the UFN")
MVS (* ;
 "T if the UFN can returnmultiple values. If this is NIL, MVs WILL NOT BE PRESERVED.")
))
(RECORD MISCN-UFN-SPEC (NAME INDEX UFN-NAME MVS))
(BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG)
(NIL BITS 3)
(MISCN-UFN POINTER)))
(NIL BITS 3)
(MISCN-UFN POINTER)))
)
)
@@ -218,7 +206,7 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN)
(SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))
(SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))
(* "END EXPORTED DEFINITIONS")
@@ -233,7 +221,7 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
(* ;; "Make Sure \USER-SUBR-TABLE is made")
(IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE)
\USER-SUBR-TABLE))
\USER-SUBR-TABLE))
THEN (\INIT-USER-SUBR-TABLE))
(* ;; "See if the Name is already defined")
@@ -450,9 +438,9 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
,@ARGS])
(DEFOPTIMIZER SUBRCALL (NAME &REST ARGS)
`((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
,(LENGTH ARGS))
,@ARGS))
`((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
,(LENGTH ARGS))
,@ARGS))
(DEFINEQ
(SUBRNUMBER
@@ -612,52 +600,51 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
else NIL])
(UNIX-USERNAME
[LAMBDA NIL (* ; "Edited 1-Aug-88 23:22 by masinter")
(if (EQ \MACHINETYPE \MAIKO)
then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING)
then (CONCAT (SUBSTRING UNIXSTRING 1
(CL:POSITION #\Null UNIXSTRING
])
[LAMBDA NIL (* ; "Edited 5-Feb-2026 23:24 by rmk")
(* ; "Edited 1-Aug-88 23:22 by masinter")
(WITH-RESOURCE UNIXSTRING (CL:WHEN (SUBRCALL UNIX-USERNAME UNIXSTRING)
(SYSTOMSTRING (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null
UNIXSTRING))))])
(UNIX-FULLNAME
[LAMBDA NIL (* ; "Edited 18-Jul-88 03:47 by masinter")
(if (EQ \MACHINETYPE \MAIKO)
then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING)
then (CONCAT (SUBSTRING UNIXSTRING 1
(CL:POSITION #\Null
UNIXSTRING])
[LAMBDA NIL (* ; "Edited 5-Feb-2026 23:24 by rmk")
(* ; "Edited 18-Jul-88 03:47 by masinter")
(WITH-RESOURCES UNIXSTRING (CL:WHEN (SUBRCALL UNIX-FULLNAME UNIXSTRING)
(SYSTOMSTRING (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null
UNIXSTRING))))])
(UNIX-GETENV
[LAMBDA (NAME) (* ; "Edited 21-Feb-2021 21:09 by larry")
(WITH-RESOURCES
UNIXSTRING
(LET ((X UNIXSTRING))
(if (SUBRCALL UNIX-GETENV (MKSTRING NAME)
X)
then (CONCAT (SUBSTRING X 1 (for I from 1
do (if (FMEMB (NTHCHARCODE X I)
'(0 NIL))
then (RETURN (SUB1 I])
[LAMBDA (NAME) (* ; "Edited 5-Feb-2026 23:25 by rmk")
(* ; "Edited 31-Jan-2026 22:28 by rmk")
(* ; "Edited 21-Feb-2021 21:09 by larry")
(WITH-RESOURCES UNIXSTRING
(CL:WHEN (SUBRCALL UNIX-GETENV (MTOSYSSTRING NAME)
UNIXSTRING)
[SYSTOMSTRING (SUBSTRING UNIXSTRING 1
(for I from 1
do (if (FMEMB (NTHCHARCODE UNIXSTRING I)
'(0 NIL))
then (RETURN (SUB1 I])])
(UNIX-GETPARM
[LAMBDA (NAME) (* ; "Edited 27-Feb-91 17:11 by nm")
[LAMBDA (NAME) (* ; "Edited 5-Feb-2026 23:21 by rmk")
(* ; "Edited 27-Feb-91 17:11 by nm")
(* ;; "Read information from the C emulator. Usually gets info about configuration of the machine we're running on.")
(* ;;
"Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.")
 "Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.")
(* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.")
(if (EQ \MACHINETYPE \MAIKO)
then (LET (LEN)
(WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME)
UNIXSTRING))
(COND
[(SMALLP LEN)
(if (> LEN 0)
then (CONCAT (SUBSTRING UNIXSTRING 1 LEN]
(LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING])
(LET (LEN)
(WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MTOSYSSTRING NAME)
UNIXSTRING))
(COND
[(SMALLP LEN)
(if (> LEN 0)
then (SYSTOMSTRING (SUBSTRING UNIXSTRING 1 LEN]
(LEN (SYSTOMSTRING (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING])
)
(PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH))
@@ -684,20 +671,19 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
(PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR))
(PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE)
(PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992
2021))
(PUTPROPS LLSUBRS FILETYPE :FAKE-COMPILE-FILE)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3639 8383 (MISCN-NUMBER 3649 . 3865) (\MISCN.UFN 3867 . 6124) (\UNDEFINED-MISCN-UFN
6126 . 6442) (MISCN-COLLECT 6444 . 6661) (\GET-MY-BF 6663 . 6875) (\INIT-MISCN-TABLE 6877 . 8381)) (
9767 11056 (ADD-USER-SUBR 9767 . 11056)) (11057 12808 (\USER-SUBR-UFN 11067 . 11642) (
\INIT-USER-SUBR-TABLE 11644 . 12109) (\UNDEFINED-USER-SUBR-UFN 12111 . 12454) (USER-SUBR-NUMBER 12456
. 12678) (EQ-TO-CAR 12680 . 12741) (EQ-TO-CADR 12743 . 12806)) (17091 17740 (SUBRNUMBER 17101 . 17738
)) (17801 20104 (WRITECALLSUBRS 17811 . 19347) (FIX-SUBR-NAME 19349 . 20102)) (20313 26217 (
\MOREVMEMFILE 20323 . 20488) (\WRITEMAP 20490 . 20650) (\COPYSYS0SUBR 20652 . 20812) (\PUPLEVEL1STATE
20814 . 20978) (SHOWDISPLAY 20980 . 21269) (SETSCREENCOLOR 21271 . 21434) (\WRITERAWPBI 21436 . 21594)
(\READRAWPBI 21596 . 21748) (RAID 21750 . 21905) (\LISPFINISH 21907 . 22065) (\GETPACKETBUFFER 22067
. 22229) (\GATHERSTATS 22231 . 22389) (\DSPRATE 22391 . 22658) (DSPBOUT 22660 . 22814) (DISKPARTITION
22816 . 23111) (\CHECKBCPLPASSWORD 23113 . 23292) (SUSPEND-LISP 23294 . 23552) (UNIX-USERNAME 23554
. 24076) (UNIX-FULLNAME 24078 . 24604) (UNIX-GETENV 24606 . 25203) (UNIX-GETPARM 25205 . 26215)))))
(FILEMAP (NIL (2955 3362 (MISCN 2955 . 3362)) (3544 8288 (MISCN-NUMBER 3554 . 3770) (\MISCN.UFN 3772
. 6029) (\UNDEFINED-MISCN-UFN 6031 . 6347) (MISCN-COLLECT 6349 . 6566) (\GET-MY-BF 6568 . 6780) (
\INIT-MISCN-TABLE 6782 . 8286)) (8844 8979 (USER-SUBR 8844 . 8979)) (8981 10266 (ADD-USER-SUBR 8981 .
10266)) (10267 12018 (\USER-SUBR-UFN 10277 . 10852) (\INIT-USER-SUBR-TABLE 10854 . 11319) (
\UNDEFINED-USER-SUBR-UFN 11321 . 11664) (USER-SUBR-NUMBER 11666 . 11888) (EQ-TO-CAR 11890 . 11951) (
EQ-TO-CADR 11953 . 12016)) (15683 16094 (SUBRCALL 15683 . 16094)) (16289 16938 (SUBRNUMBER 16299 .
16936)) (16999 19302 (WRITECALLSUBRS 17009 . 18545) (FIX-SUBR-NAME 18547 . 19300)) (19511 25586 (
\MOREVMEMFILE 19521 . 19686) (\WRITEMAP 19688 . 19848) (\COPYSYS0SUBR 19850 . 20010) (\PUPLEVEL1STATE
20012 . 20176) (SHOWDISPLAY 20178 . 20467) (SETSCREENCOLOR 20469 . 20632) (\WRITERAWPBI 20634 . 20792)
(\READRAWPBI 20794 . 20946) (RAID 20948 . 21103) (\LISPFINISH 21105 . 21263) (\GETPACKETBUFFER 21265
. 21427) (\GATHERSTATS 21429 . 21587) (\DSPRATE 21589 . 21856) (DSPBOUT 21858 . 22012) (DISKPARTITION
22014 . 22309) (\CHECKBCPLPASSWORD 22311 . 22490) (SUSPEND-LISP 22492 . 22750) (UNIX-USERNAME 22752
. 23256) (UNIX-FULLNAME 23258 . 23765) (UNIX-GETENV 23767 . 24583) (UNIX-GETPARM 24585 . 25584)))))
STOP

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

221
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 "17-Oct-2025 08:50:00" {WMEDLEY}<sources>MCCS.;155 57020
(FILECREATED "26-Feb-2026 12:57:11" {WMEDLEY}<sources>MCCS.;168 61634
:EDIT-BY rmk
:CHANGES-TO (VARS MCCSCOMS)
:CHANGES-TO (FNS MCCSMAPPAIRS)
:PREVIOUS-DATE "15-Oct-2025 18:31:01" {WMEDLEY}<sources>MCCS.;154)
:PREVIOUS-DATE "20-Feb-2026 09:21:16" {WMEDLEY}<sources>MCCS.;167)
(PRETTYCOMPRINT MCCSCOMS)
@@ -17,14 +17,14 @@
(FNS \MCCSINCCODE \MCCSPEEKCCODE \MCCSOUTCHAR \MCCSBACKCCODE \MCCSFORMATBYTESTREAM
\MCCSCHARSETFN)
(FNS \CREATE.MCCS.EXTERNALFORMAT)
(FNS \CREATE.MCCS.EXTERNALFORMAT \CREATE.XCCS.EXTERNALFORMAT)
(FNS \MCCS.24BITENCODING.ERROR)
(INITVARS (*SIGNAL-MCCS.24BITENCODING.ERROR*))
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (CONSTANTS (\NORUNCODE 255)
(NSCHARSETSHIFT 255))
(MACROS \RUNCODED)))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.MCCS.EXTERNALFORMAT :MCCS)
(\CREATE.MCCS.EXTERNALFORMAT :XCCS)))
(\CREATE.XCCS.EXTERNALFORMAT :XCCS)))
(* ;; "")
@@ -57,7 +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])
CYRILLICTOMCODE PALATINOTOMCODE))
(COMS (FNS SYSTEM-EXTERNALFORMAT MTOSYSSTRING SYSTOMSTRING)
(EXPORT (GLOBALVARS *SYSTEM-EXTERNALFORMAT*))
(INITVARS (*SYSTEM-EXTERNALFORMAT* :UTF-8])
@@ -291,6 +294,33 @@
(FUNCTION \MCCSFORMATBYTESTREAM)
(OR EOL 'LF)
T NIL NIL (FUNCTION \MCCSCHARSETFN])
(\CREATE.XCCS.EXTERNALFORMAT
[LAMBDA (NAME EOL) (* ; "Edited 5-Feb-2026 15:54 by rmk")
(* ; "Edited 1-Feb-2026 12:22 by rmk")
(* ; "Edited 23-Apr-2025 14:19 by rmk")
(* ; "Edited 7-Dec-2023 23:03 by rmk")
(* ; "Edited 30-Jun-2022 18:08 by rmk")
(* ; "Edited 10-Sep-2021 19:49 by rmk:")
(* ;;; "Create the :XCCS external format. Stream's EOL overrides the (vacuous) default here. Just like :MCCS except for switch of underscore-circumflex/arrows.")
(MAKE-EXTERNALFORMAT (OR NAME :XCCS)
[FUNCTION (LAMBDA (STREAM COUNTP)
(XTOMCODE (\MCCSINCCODE STREAM COUNTP]
[FUNCTION (LAMBDA (STREAM NOERROR)
(XTOMCODE (\MCCSPEEKCCODE STREAM NOERROR]
[FUNCTION (LAMBDA (STREAM COUNTP)
(XTOMCODE (\MCCSBACKCCODE STREAM COUNTP]
[FUNCTION (LAMBDA (STREAM CHARCODE)
(\MCCSOUTCHAR STREAM (MTOXCODE CHARCODE]
(FUNCTION \MCCSFORMATBYTESTREAM)
(OR EOL 'LF)
T
(FUNCTION MTOXSTRING)
NIL
(FUNCTION \MCCSCHARSETFN)
(FUNCTION XTOMSTRING])
)
(DEFINEQ
@@ -338,7 +368,7 @@
(\CREATE.MCCS.EXTERNALFORMAT :MCCS)
(\CREATE.MCCS.EXTERNALFORMAT :XCCS)
(\CREATE.XCCS.EXTERNALFORMAT :XCCS)
)
@@ -393,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])
@@ -404,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])
@@ -466,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")
@@ -1246,7 +1276,9 @@
(DEFINEQ
(MCCSCODEMAPARRAY
[LAMBDA (MAP) (* ; "Edited 6-Sep-2025 18:26 by rmk")
[LAMBDA (MAP INVERT) (* ; "Edited 5-Feb-2026 11:02 by rmk")
(* ; "Edited 2-Feb-2026 23:11 by rmk")
(* ; "Edited 6-Sep-2025 18:26 by rmk")
(* ; "Edited 31-Aug-2025 16:15 by rmk")
(* ; "Edited 7-Aug-2025 08:55 by rmk")
(* ; "Edited 2-Jun-2025 11:45 by rmk")
@@ -1260,19 +1292,28 @@
(XCCS (SETQ MAP (APPEND MTOXCODEMAP ALTOTEXT2MCCS)))
(MCCS (SETQ MAP ALTOTEXT2MCCS))
NIL)
(LET ((TABLE (ARRAY (ADD1 \MAXTHINCHAR)
'WORD 0 0)))
(for I from 0 to \MAXTHINCHAR do (SETA TABLE I I))
(LET ((ARRAY (ARRAY (ADD1 \MAXTHINCHAR)
'WORD 0 0))
HARRAY)
(for I from 0 to \MAXTHINCHAR do (SETA ARRAY I I)) (* ; "Default")
[for PAIR FROMCODE in MAP when (LISTP PAIR) unless (EQ '* (CAR PAIR))
when (SETQ FROMCODE (CL:IF (CHARCODEP (CAR PAIR))
(CAR PAIR)
when (SETQ FROMCODE (OR (CHARCODEP (CAR PAIR))
(CHARCODE.DECODE (CAR PAIR)
T))) do (SETA TABLE FROMCODE (CL:IF (CHARCODEP
(CADR PAIR))
(CADR PAIR)
T))) do (SETA ARRAY FROMCODE (OR (CHARCODEP (CADR PAIR))
(CHARCODE.DECODE
(CADR PAIR)))]
TABLE])
(CADR PAIR]
(CL:WHEN INVERT
(SETQ HARRAY (HASHARRAY 20))
(for I from 0 to \MAXTHINCHAR do (PUTHASH I I HARRAY))
(for PAIR FROMCODE in MAP when (LISTP PAIR) unless (EQ '* (CAR PAIR))
do (PUTHASH (OR (CHARCODEP (CADR PAIR))
(CHARCODE.DECODE (CADR PAIR)))
(OR (CHARCODEP (CAR PAIR))
(CHARCODE.DECODE (CAR PAIR)))
HARRAY)))
(CL:IF HARRAY
(LIST ARRAY HARRAY)
ARRAY)])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
@@ -1327,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")
@@ -1335,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")
@@ -1378,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")
@@ -1418,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)])
@@ -1496,16 +1543,52 @@
MCODE)))
PCODE])
)
(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%: DONTCOPY
(FILEMAP (NIL (2853 14424 (\MCCSINCCODE 2863 . 5951) (\MCCSPEEKCCODE 5953 . 8840) (\MCCSOUTCHAR 8842
. 10941) (\MCCSBACKCCODE 10943 . 12487) (\MCCSFORMATBYTESTREAM 12489 . 13219) (\MCCSCHARSETFN 13221
. 14422)) (14425 15307 (\CREATE.MCCS.EXTERNALFORMAT 14435 . 15305)) (15308 16285 (
\MCCS.24BITENCODING.ERROR 15318 . 16283)) (17661 20299 (MTOXCODE 17671 . 18468) (XTOMCODE 18470 .
19127) (XTOMSTRING 19129 . 19714) (MTOXSTRING 19716 . 20297)) (20300 21960 (MTOX$CODE 20310 . 21042) (
X$TOMCODE 21044 . 21958)) (21961 22601 (KANJICHARSETP 21971 . 22227) (CHINESECHARSETP 22229 . 22599))
(43169 45043 (MCCSCODEMAPARRAY 43179 . 45041)) (45659 52140 (MCCSMAPFN 45669 . 47036) (MCCSMAPPAIRS
47038 . 51146) (XCCS.CS0.UNDEFINED 51148 . 51777) (XCCSUNDEFINEDPAIRS 51779 . 52138)) (52245 56997 (
GACHATOMCODE 52255 . 52767) (SYMBOLTOMCODE 52769 . 53417) (SIGMATOMCODE 53419 . 54065) (ATOMCODE 54067
. 54599) (MATHTOMCODE 54601 . 55257) (HIPPOTOMCODE 55259 . 55796) (CYRILLICTOMCODE 55798 . 56232) (
PALATINOTOMCODE 56234 . 56995)))))
(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.

15
sources/MEDLEYDIR
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Nov-2025 21:51:39" {WMEDLEY}<sources>MEDLEYDIR.;43 15970
(FILECREATED "31-Jan-2026 23:43:06" {WMEDLEY}<sources>MEDLEYDIR.;44 16074
:EDIT-BY rmk
:CHANGES-TO (VARS MEDLEYDIRCOMS)
:CHANGES-TO (FNS MEDLEYDIR)
:PREVIOUS-DATE "26-Nov-2025 17:12:16" {WMEDLEY}<sources>MEDLEYDIR.;42)
:PREVIOUS-DATE "26-Nov-2025 21:51:39" {WMEDLEY}<sources>MEDLEYDIR.;43)
(PRETTYCOMPRINT MEDLEYDIRCOMS)
@@ -139,7 +139,8 @@
NIL])
(MEDLEYDIR
[LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ; "Edited 23-Aug-2025 17:21 by lmm")
[LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ; "Edited 31-Jan-2026 23:42 by rmk")
(* ; "Edited 23-Aug-2025 17:21 by lmm")
(* ; "Edited 18-Aug-2025 11:15 by FGH")
(* ; "Edited 29-Jun-2023 22:48 by rmk")
(* ; "Edited 18-Oct-2022 17:49 by lmm")
@@ -184,7 +185,7 @@
(UNIX-GETENV "HOME")
DIRNAME)))
[(EQUAL DIRNAME "loadups") (* ; "special case for loadups dir")
(OR (DIRECTORYNAME (UNIX-GETENV "MEDLEY_LOADUPS_DIR"))
(OR (DIRECTORYNAME (UNIX-GETENV "MEDLEY¬LOADUPS¬DIR"))
(DIRECTORYNAME (CONCAT (MEDLEYDIR)
"loadups" ">")
NIL OUTPUT)
@@ -284,6 +285,6 @@
(ADDTOVAR GLOBALVARS MEDLEYDIR MEDLEY-INIT-VARS \SAVE.MEDLEYDIR DIRECTORIES SYSOUTCOMMITS)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (5329 13232 (MEDLEY-INIT-VARS 5339 . 8817) (MEDLEYDIR 8819 . 12032) (MEDLEYSUBSTDIR
12034 . 13012) (SET-SYSOUT-COMMIT 13014 . 13230)))))
(FILEMAP (NIL (5324 13336 (MEDLEY-INIT-VARS 5334 . 8812) (MEDLEYDIR 8814 . 12136) (MEDLEYSUBSTDIR
12138 . 13116) (SET-SYSOUT-COMMIT 13118 . 13334)))))
STOP

BIN
sources/MEDLEYDIR.LCOM
View File

Binary file not shown.

34
sources/MEDLEYFONTFORMAT
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "23-Jan-2026 15:10:16" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;249 60332
(FILECREATED "14-Feb-2026 00:39:34" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;250 60733
:EDIT-BY rmk
:CHANGES-TO (FNS MEDLEYFONT.FILENAME MEDLEYFONT.WRITE.FONT MEDLEYFONT.READ.FONT
MEDLEYFONT.READ.VERIFIEDFONT)
:CHANGES-TO (FNS MEDLEYFONT.GETCHARSET MEDLEYFONT.READ.CHARSET)
:PREVIOUS-DATE " 9-Oct-2025 15:20:59" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;242)
:PREVIOUS-DATE "23-Jan-2026 15:10:16" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;249)
(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS)
@@ -130,7 +129,8 @@
(FULLNAME STREAM])
(MEDLEYFONT.GETCHARSET
[LAMBDA (STREAM CHARSET FONT) (* ; "Edited 9-Oct-2025 15:18 by rmk")
[LAMBDA (STREAM CHARSET FONT) (* ; "Edited 14-Feb-2026 00:36 by rmk")
(* ; "Edited 9-Oct-2025 15:18 by rmk")
(* ; "Edited 3-Sep-2025 11:32 by rmk")
(* ; "Edited 15-Jul-2025 17:09 by rmk")
(* ; "Edited 9-Jul-2025 15:45 by rmk")
@@ -185,7 +185,7 @@
(SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL)))
(CL:UNLESS (EQ 0 (SETQ CSLOC (\FIXPIN STREAM)))
(SETFILEPTR STREAM CSLOC)))
(MEDLEYFONT.READ.CHARSET STREAM CHARSET))))])
(MEDLEYFONT.READ.CHARSET STREAM CHARSET FONT))))])
(MEDLEYFONT.CHARSET?
[LAMBDA (FILE CHARSET) (* ; "Edited 15-Jul-2025 15:21 by rmk")
@@ -343,7 +343,8 @@
FONT])
(MEDLEYFONT.READ.CHARSET
[LAMBDA (STREAM CHARSET) (* ; "Edited 4-Sep-2025 10:39 by rmk")
[LAMBDA (STREAM CHARSET FONT) (* ; "Edited 14-Feb-2026 00:36 by rmk")
(* ; "Edited 4-Sep-2025 10:39 by rmk")
(* ; "Edited 28-Aug-2025 15:27 by rmk")
(* ; "Edited 26-Aug-2025 23:36 by rmk")
(* ; "Edited 17-Aug-2025 13:01 by rmk")
@@ -356,6 +357,9 @@
(* ; "Edited 16-May-2025 20:19 by rmk")
(* ; "Edited 14-May-2025 10:43 by rmk")
(* ; "Edited 12-May-2025 07:55 by rmk")
(* ;; "FONT is only needed for the \READCHARSET call below that interprets an INDIRECT and leads to a recursiving invocation of MEDLEYFONT.GETCHARSET and this function. It is the font descriptor provided at the top-level call. ")
(MEDLEYFONT.READ.ITEM STREAM 'CHARSETSTRING) (* ;
 "Throwaway for looking with text editor")
(LET (CSNO INDIRECT)
@@ -366,7 +370,7 @@
(* ;; "Read what we peeked and use it to create a complete charset from another file (e.g. shared Kanji). ")
(SETQ INDIRECT (MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET))
(\READCHARSET INDIRECT CHARSET)
(\READCHARSET INDIRECT CHARSET FONT)
else (bind PAIR LABEL ITEM (CSINFO _ (create CHARSETINFO
WIDTHS _ NIL
OFFSETS _ NIL)) eachtime (SETQ PAIR
@@ -920,11 +924,11 @@
)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2222 16857 (MEDLEYFONT.WRITE.FONT 2232 . 7287) (MEDLEYFONT.GETCHARSET 7289 . 11316) (
MEDLEYFONT.CHARSET? 11318 . 12787) (MEDLEYFONT.GETFILEPROP 12789 . 14889) (MEDLEYFONT.FILEP 14891 .
16855)) (16883 39217 (MEDLEYFONT.READ.FONT 16893 . 21429) (MEDLEYFONT.READ.CHARSET 21431 . 26789) (
MEDLEYFONT.READ.ITEM 26791 . 32940) (MEDLEYFONT.PEEK.ITEM 32942 . 33804) (MEDLEYFONT.READ.FONTPROPS
33806 . 34271) (MEDLEYFONT.READ.VERIFIEDFONT 34273 . 39215)) (39243 57080 (MEDLEYFONT.WRITE.CHARSET
39253 . 43815) (MEDLEYFONT.WRITE.ITEM 43817 . 52870) (MEDLEYFONT.WRITE.FONTPROPS 52872 . 56425) (
MEDLEYFONT.WRITE.HEADER 56427 . 57078)) (57081 59447 (MEDLEYFONT.FILENAME 57091 . 59445)))))
(FILEMAP (NIL (2152 16901 (MEDLEYFONT.WRITE.FONT 2162 . 7217) (MEDLEYFONT.GETCHARSET 7219 . 11360) (
MEDLEYFONT.CHARSET? 11362 . 12831) (MEDLEYFONT.GETFILEPROP 12833 . 14933) (MEDLEYFONT.FILEP 14935 .
16899)) (16927 39618 (MEDLEYFONT.READ.FONT 16937 . 21473) (MEDLEYFONT.READ.CHARSET 21475 . 27190) (
MEDLEYFONT.READ.ITEM 27192 . 33341) (MEDLEYFONT.PEEK.ITEM 33343 . 34205) (MEDLEYFONT.READ.FONTPROPS
34207 . 34672) (MEDLEYFONT.READ.VERIFIEDFONT 34674 . 39616)) (39644 57481 (MEDLEYFONT.WRITE.CHARSET
39654 . 44216) (MEDLEYFONT.WRITE.ITEM 44218 . 53271) (MEDLEYFONT.WRITE.FONTPROPS 53273 . 56826) (
MEDLEYFONT.WRITE.HEADER 56828 . 57479)) (57482 59848 (MEDLEYFONT.FILENAME 57492 . 59846)))))
STOP

BIN
sources/MEDLEYFONTFORMAT.LCOM
View File

Binary file not shown.

36
sources/PACKAGE-STARTUP
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "21-Mar-2024 10:21:14" |{DSK}<home>larry>il>medley>sources>PACKAGE-STARTUP.;9| 36658
(FILECREATED " 8-Feb-2026 11:47:57" |{WMEDLEY}<sources>PACKAGE-STARTUP.;6| 36725
:EDIT-BY "lmm"
:EDIT-BY |rmk|
:CHANGES-TO (VARIABLES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.SHARED)
:CHANGES-TO (FUNCTIONS PACKAGE-ENABLE)
:PREVIOUS-DATE "20-Mar-2024 23:34:56" |{DSK}<home>larry>il>medley>sources>PACKAGE-STARTUP.;8|
)
:PREVIOUS-DATE "21-Mar-2024 10:21:14" |{WMEDLEY}<sources>PACKAGE-STARTUP.;5|)
(PRETTYCOMPRINT PACKAGE-STARTUPCOMS)
@@ -566,7 +565,8 @@
(CONCOCT-SYMBOL I))
T)
(CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*))
(CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*))
(* \; "Edited 8-Feb-2026 11:47 by rmk")
"Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly."
(DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *PACKAGE* *OLD-INTERLISP-READ-ENVIRONMENT*
*PER-EXEC-VARIABLES*))
@@ -594,8 +594,8 @@
(T (PROMPTPRINT "Invalid package, reset to LISP")
(SETQ *PACKAGE* (CL:FIND-PACKAGE "LISP")))))
*PER-EXEC-VARIABLES* :TEST 'CL:EQUAL)
(CL:SETF *DEFAULT-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT
:XCCS))
(CL:SETF *DEFAULT-MAKEFILE-ENVIRONMENT* `(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT
,*DEFAULT-EXTERNALFORMAT*))
(MOVD '\\NEW.READ.SYMBOL '\\READ.SYMBOL)
(MOVD '\\NEW.MKATOM '\\MKATOM)
(CL:SETF *PACKAGE* PACKAGE)
@@ -644,14 +644,14 @@
(PACKAGE-INIT)
)
(DECLARE\: DONTCOPY
(FILEMAP (NIL (3038 3133 (RETURN-FIRST-OF-THREE 3038 . 3133)) (3135 3273 (
ERROR-MISSING-EXTERNAL-SYMBOL 3135 . 3273)) (3880 4848 (CHECK-SYMBOL-NAMESTRING 3880 . 4848)) (4850
8008 (\\NEW.READ.SYMBOL 4850 . 8008)) (8010 9720 (\\NEW.MKATOM 8010 . 9720)) (23549 23631 (
LITATOM.EXISTS 23549 . 23631)) (24311 25317 (NAMESTRING-CONVERSION-CLAUSE 24311 . 25317)) (25319 26574
(CONVERT-LITATOM 25319 . 26574)) (26576 28649 (CONCOCT-SYMBOL 26576 . 28649)) (28651 28945 (
TRANSFER-SYMBOL 28651 . 28945)) (28947 29655 (INTERN-LITATOM 28947 . 29655)) (29657 30336 (
\\LITATOM.EATCHARS 29657 . 30336)) (30338 30615 (PACKAGE-INIT 30338 . 30615)) (30617 31190 (
PACKAGE-CLEAR 30617 . 31190)) (31192 32583 (PACKAGE-MAKE 31192 . 32583)) (32585 33897 (
PACKAGE-HIERARCHY-INIT 32585 . 33897)) (33899 35508 (PACKAGE-ENABLE 33899 . 35508)) (35510 36153 (
PACKAGE-DISABLE 35510 . 36153)) (36200 36226 (ID 36200 . 36226)))))
(FILEMAP (NIL (2977 3072 (RETURN-FIRST-OF-THREE 2977 . 3072)) (3074 3212 (
ERROR-MISSING-EXTERNAL-SYMBOL 3074 . 3212)) (3819 4787 (CHECK-SYMBOL-NAMESTRING 3819 . 4787)) (4789
7947 (\\NEW.READ.SYMBOL 4789 . 7947)) (7949 9659 (\\NEW.MKATOM 7949 . 9659)) (23488 23570 (
LITATOM.EXISTS 23488 . 23570)) (24250 25256 (NAMESTRING-CONVERSION-CLAUSE 24250 . 25256)) (25258 26513
(CONVERT-LITATOM 25258 . 26513)) (26515 28588 (CONCOCT-SYMBOL 26515 . 28588)) (28590 28884 (
TRANSFER-SYMBOL 28590 . 28884)) (28886 29594 (INTERN-LITATOM 28886 . 29594)) (29596 30275 (
\\LITATOM.EATCHARS 29596 . 30275)) (30277 30554 (PACKAGE-INIT 30277 . 30554)) (30556 31129 (
PACKAGE-CLEAR 30556 . 31129)) (31131 32522 (PACKAGE-MAKE 31131 . 32522)) (32524 33836 (
PACKAGE-HIERARCHY-INIT 32524 . 33836)) (33838 35575 (PACKAGE-ENABLE 33838 . 35575)) (35577 36220 (
PACKAGE-DISABLE 35577 . 36220)) (36267 36293 (ID 36267 . 36293)))))
STOP

BIN
sources/PACKAGE-STARTUP.LCOM
View File

Binary file not shown.

317
sources/UFS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Jan-2026 11:06:10" {WMEDLEY}<sources>UFS.;62 91935
(FILECREATED " 6-Feb-2026 23:23:31" {WMEDLEY}<sources>UFS.;68 92871
:EDIT-BY rmk
:CHANGES-TO (VARS UFSCOMS)
:CHANGES-TO (FNS \UFS.NEXTFILEFN \UFSGenerateFiles \UFSDirectoryNameP \UFS.DIRECTORY.NAME)
:PREVIOUS-DATE "27-Oct-2025 11:10:55" {WMEDLEY}<sources>UFS.;61)
:PREVIOUS-DATE " 5-Feb-2026 18:34:38" {WMEDLEY}<sources>UFS.;66)
(PRETTYCOMPRINT UFSCOMS)
@@ -14,11 +14,6 @@
(RPAQQ UFSCOMS
[(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
UFS)
[COMS
(* ;; "For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed.")
(P (MOVD? 'EVQ 'UTF8TOMSTRING)
(MOVD? 'EVQ 'MTOUTF8STRING]
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
DIRECTORY FILEIO))
(INITVARS (\UFS.DEFAULT.EOLC NIL))
@@ -135,17 +130,6 @@
(PUTPROPS UFS FILETYPE :BCOMPL)
(PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10))
(* ;;
"For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed."
)
(MOVD? 'EVQ 'UTF8TOMSTRING)
(MOVD? 'EVQ 'MTOUTF8STRING)
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY
(FILESLOAD (LOADCOMP)
@@ -290,7 +274,8 @@
(DEFINEQ
(\UFSOpenFile
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 16-Oct-2025 08:52 by rmk")
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 08:52 by rmk")
(* ; "Edited 6-Jun-90 12:18 by nm")
(* ;;; "Open a file.")
@@ -355,7 +340,7 @@
(\UFSError CASE.CORRECT.NAME 23 FDEV)))
(SETQ CDATE (CREATECELL \FIXP))
(SETQ BYTESIZE (CREATECELL \FIXP))
[SETQ FILEID (OR (\UFSOpenFile-C (MTOUTF8STRING CASE.CORRECT.FULLFILENAME)
[SETQ FILEID (OR (\UFSOpenFile-C (MTOSYSSTRING CASE.CORRECT.FULLFILENAME)
REC ACC CDATE BYTESIZE ERRNO)
(RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV]
(if (= (IPLUS BYTESIZE 0)
@@ -398,7 +383,8 @@
)
(\UFS.RECOGNIZE.FILE
[LAMBDA (FILENAME RECOG DEV) (* ; "Edited 16-Oct-2025 10:19 by rmk")
[LAMBDA (FILENAME RECOG DEV) (* ; "Edited 5-Feb-2026 18:32 by rmk")
(* ; "Edited 16-Oct-2025 10:19 by rmk")
(* ; "Edited 13-Mar-90 11:19 by nm")
(* ;; "This assumes that input FILENAME is MCCS, returns MCCS")
@@ -410,7 +396,7 @@
(ERRNO (CREATECELL \FIXP))
LEN)
(SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV)
(MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD FILENAME DEV))
(MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD FILENAME DEV))
(SELECTQ RECOG
(OLD RECOG-OLD)
(OLDEST RECOG-OLDEST)
@@ -421,28 +407,28 @@
NAMEAREA ERRNO))
(COND
((FIXP LEN)
(UTF8TOMSTRING (SUBSTRING NAMEAREA 1 LEN)))
(SYSTOMSTRING (SUBSTRING NAMEAREA 1 LEN)))
(T (\UFSError FILENAME ERRNO])])
(\UFS.DIRECTORY.NAME
[LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 15-Oct-2025 16:30 by rmk")
[LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 6-Feb-2026 18:23 by rmk")
(* ; "Edited 15-Oct-2025 16:30 by rmk")
(* ; "Edited 1-Apr-90 23:36 by nm")
(* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"true%" name of the directory in NAMEAREA and returns the length of the name. If such directory does not exist, returns NIL. The canonical directory name does not include the initial directory delimiter and the trail directory delimiter, but the result %"true%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.")
(* ;; "DIRSTRING is MCCS, the true name is not")
(* ;; "DIRSTRING is in system format")
(if (STREQUAL DIRSTRING "<")
then (RPLSTRING NAMEAREA 1 "<")
1
else (WITH.MONITOR (\UFSGetMonitor DEV)
(CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV)
(MTOUTF8STRING DIRSTRING)
NAMEAREA
(CREATECELL \FIXP)))])
DIRSTRING NAMEAREA (CREATECELL \FIXP)))])
(\UFSCloseFile
[LAMBDA (STREAMFILE) (* ; "Edited 16-Oct-2025 13:47 by rmk")
[LAMBDA (STREAMFILE) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 13:47 by rmk")
(* ; "Edited 16-Sep-2023 09:21 by briggs")
(* ; "Edited 30-Mar-90 10:39 by nm")
(* ; "return stream")
@@ -467,7 +453,7 @@
then (* ; "Open for output")
(FDEVOP 'TRUNCATEFILE DEVICE STREAMFILE)
(SETQ CDATE (fetch (UFSSTREAM CDATE) of STREAMFILE)))
(RETURN (if (\UFSCloseFile-C (MTOUTF8STRING UNIXNAME)
(RETURN (if (\UFSCloseFile-C (MTOSYSSTRING UNIXNAME)
(fetch (UFSSTREAM FILEID) of STREAMFILE)
CDATE ERRNO)
then (replace (UFSSTREAM FILEID) of STREAMFILE with NIL)
@@ -482,7 +468,8 @@
)
(\UFSDeleteFile
[LAMBDA (FILENAME DEV) (* ; "Edited 27-Oct-2025 11:10 by rmk")
[LAMBDA (FILENAME DEV) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 27-Oct-2025 11:10 by rmk")
(* ; "Edited 30-Mar-90 10:46 by nm")
(* ; "return deleted file name")
(* ; "if error, return NIL")
@@ -493,14 +480,15 @@
 "file found and not open, so try to delete")
(LET ((ERRNO (CREATECELL \FIXP)))
(COND
((\UFSDeleteFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NAME DEV))
((\UFSDeleteFile-C (MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD NAME DEV))
DEV ERRNO) (* ; "Success")
(\UFS.FULLNAME NAME DEV T))
(T (* ; "Failure")
(\UFSError NAME ERRNO DEV])])
(\UFSRenameFile
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 16-Oct-2025 08:46 by rmk")
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 08:46 by rmk")
(* ; "Edited 18-Dec-2024 12:52 by rmk")
(* ; "Edited 16-Apr-90 13:46 by nm")
(if (NEQ OLD-DEVICE NEW-DEVICE)
@@ -518,10 +506,10 @@
(LET ((NEWUNIXNAME (\UFS.RECOGNIZE.FILE NEW-NAME 'NEW NEW-DEVICE))
(ERRNO (CREATECELL \FIXP)))
(COND
((\UFSRenameFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD
OLDUNIXNAME OLD-DEVICE))
(MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME
NEW-DEVICE))
((\UFSRenameFile-C (MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD OLDUNIXNAME
OLD-DEVICE))
(MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME NEW-DEVICE
))
NEW-DEVICE ERRNO)
(\UFS.FULLNAME NEWUNIXNAME NEW-DEVICE))
(T (if (EQL (IPLUS ERRNO 0)
@@ -543,7 +531,8 @@
)
(\UFSTruncateFile
[LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 16-Oct-2025 08:56 by rmk")
[LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 08:56 by rmk")
(* ; "Edited 22-Aug-90 16:46 by nm")
(* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.")
@@ -581,16 +570,19 @@
(* ;;
 "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.")
(if (\UFSGetFileInfo-C (MTOUTF8STRING (fetch (UFSSTREAM UNIXNAME) of STREAM))
(if (\UFSGetFileInfo-C (MTOSYSSTRING (fetch (UFSSTREAM UNIXNAME) of STREAM))
ATTR-WDATE DT ERRNO)
then (replace (STREAM VALIDATION) of STREAM with DT])
(\UFSDirectoryNameP
[LAMBDA (DIRSPEC DEV) (* ; "Edited 16-Oct-2025 10:23 by rmk")
[LAMBDA (DIRSPEC DEV) (* ; "Edited 6-Feb-2026 23:19 by rmk")
(* ; "Edited 16-Oct-2025 10:23 by rmk")
(* ; "Edited 21-Sep-92 15:27 by jds")
(* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.")
(* ;; "DIRSPEC is in system format")
(LET ([DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC 'DEVICE)
"")
(OR (UNPACKFILENAME.STRING DIRSPEC 'DIRECTORY 'RETURN)
@@ -606,12 +598,13 @@
(COND
(DIRECTORY (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN))
(* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.")
(SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV))
(SETQ LEN (\UFS.DIRECTORY.NAME (MTOSYSSTRING DIRECTORY)
NAMEAREA DEV))
(COND
((FIXP LEN) (* ;
 "LEN holds the length of the %"true%" name of DIRECTORY.")
(UTF8TOMSTRING (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN)
DEV NIL)))
(\UFS.FULLNAME (SYSTOMSTRING (SUBSTRING NAMEAREA 1 LEN))
DEV NIL))
(T NIL)))
(T NIL])
@@ -620,7 +613,8 @@
)
(\UFSGetFileInfo
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 16-Oct-2025 08:49 by rmk")
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 5-Feb-2026 18:32 by rmk")
(* ; "Edited 16-Oct-2025 08:49 by rmk")
(* ; "Edited 30-Mar-90 12:27 by nm")
(* ;;; "Get the value of the attribute for a file.")
@@ -639,7 +633,7 @@
(ERRNO (CREATECELL \FIXP))
BUFFER NAMESIZE)
(if FILENAME
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
then (SETQ FILENAME (MTOSYSSTRING FILENAME))
(SELECTQ ATTRIBUTE
(LENGTH (SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO)
@@ -671,7 +665,7 @@
(AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN))
(if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER
ERRNO))
then (UTF8TOMSTRING (CL:SUBSEQ BUFFER 0 NAMESIZE))
then (SYSTOMSTRING (CL:SUBSEQ BUFFER 0 NAMESIZE))
else (\UFSError FILENAME ERRNO DEVICE)))
(PROTECTION (SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO)
@@ -692,7 +686,8 @@
)
(\UFSSetFileInfo
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 16-Oct-2025 08:51 by rmk")
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 08:51 by rmk")
(* ; "Edited 30-Mar-90 12:31 by nm")
(* ;;; "Get the VALUE of the ATTRIBUTE for a file.")
@@ -711,7 +706,7 @@
(ERRNO (CREATECELL \FIXP))
BUFFER NAMESIZE PATHNAME)
(if FILENAME
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
then (SETQ FILENAME (MTOSYSSTRING FILENAME))
(SELECTQ ATTRIBUTE
(TYPE (\UFSSetFileType FILENAME VALUE))
((CREATIONDATE WRITEDATE)
@@ -735,6 +730,8 @@
(\UFSGenerateFiles
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS)
(* ;; "Edited 6-Feb-2026 22:43 by rmk")
(* ;; "Edited 16-Oct-2025 11:06 by rmk")
(* ;; "Edited 27-Mar-2022 15:55 by rmk: Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults")
@@ -750,8 +747,13 @@
(* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.")
(* ;;
 "All the internals are in system format, individual results must be converted back to MCCS.")
(* ;; "PATTERN is MCCS, is immediately converted to system format")
(WITH.MONITOR (\UFSGetMonitor FDEV)
[PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN))
[PROG* ((PARSED (UNPACKFILENAME.STRING (MTOSYSSTRING PATTERN)))
(DIRECTORY (OR (LISTGET PARSED 'DIRECTORY)
(\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED 'RELATIVEDIRECTORY)
FDEV)
@@ -769,27 +771,26 @@
(DEFAULTVERS (OR (LISTGET PARSED 'VERSION)
DEFAULTVERS)))
(* ;; "All fields are now in the system external format")
(* ;; "rmk: uses the default below, don't want NIL if the pattern includes something else.")
(COND
((STREQUAL DIRECTORY "/")
(SETQ DIRECTORY "<")))
(* ;; "DIRECTORY is MCCS, FILTER is UTF8")
[SETQ FILTER (MTOUTF8STRING (COND
((STREQUAL DIRECTORY "<")
(CONCAT "{" (LISTGET PARSED 'HOST)
"}"
(OR DEVICE "")
"<"
(PACKFILENAME.STRING 'NAME NAME 'EXTENSION
EXTENSION 'VERSION VERSION)))
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY
'HOST
(LISTGET PARSED 'HOST)
'DEVICE DEVICE 'NAME NAME 'EXTENSION
EXTENSION 'VERSION VERSION]
[SETQ FILTER (COND
((STREQUAL DIRECTORY "<")
(CONCAT "{" (LISTGET PARSED 'HOST)
"}"
(OR DEVICE "")
"<"
(PACKFILENAME.STRING 'NAME NAME 'EXTENSION EXTENSION
'VERSION VERSION)))
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET
PARSED
'HOST)
'DEVICE DEVICE 'NAME NAME 'EXTENSION EXTENSION 'VERSION
VERSION]
(SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "")
DIRECTORY)
NAMEAREA FDEV))
@@ -797,7 +798,7 @@
((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case")
(PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory")
(RETURN (\NULLFILEGENERATOR]
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ; "DIRECTORY is now UTF8")
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN))
(* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.")
@@ -808,8 +809,7 @@
(SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO))
(COND
[(< TOTALNUM 0)
(OR (\UFSError (UTF8TOMSTRING DIRECTORY)
ERRNO FDEV)
(OR (\UFSError DIRECTORY ERRNO FDEV)
(RETURN (\NULLFILEGENERATOR]
(T (COND
((ZEROP TOTALNUM)
@@ -819,7 +819,8 @@
(FMEMB 'RESETLST OPTIONS))
(RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID]
(* ;; "Everything in FILEGENOBJ is UTF8")
(* ;;
 "Everything in FILEGENOBJ is in system character encoding (UTF-8?)")
(RETURN (create FILEGENOBJ
NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN)
@@ -842,20 +843,21 @@
CURRENT-DEPTH _ 1
MAX-DEPTH _
FILING.ENUMERATION.DEPTH
FILTER _
(PACKFILENAME.STRING
'NAME
(AND NAME (MTOUTF8STRING
NAME))
'EXTENSION
(AND EXTENSION (
MTOUTF8STRING
EXTENSION))
'VERSION VERSION])])
FILTER _ (
PACKFILENAME.STRING
'NAME NAME
'EXTENSION
EXTENSION
'VERSION VERSION])
])
(\UFS.NEXTFILEFN
[LAMBDA (GENFILESTATE NAMEONLY)
(* ;; "Edited 6-Feb-2026 23:23 by rmk")
(* ;; "Edited 5-Feb-2026 18:32 by rmk")
(* ;; "Edited 16-Oct-2025 16:59 by rmk")
(* ;;
@@ -865,7 +867,7 @@
(* ;; "Given a UFS filesystem generator, return the %"next%" file in line.")
(* ;; "All the fields of the UFSGENFILESTATE are UTF8. FILENAME is MCCS")
(* ;; "All the fields of the UFSGENFILESTATE are in system format (UTF-8?). Returned FILENAME is converted to MCCS")
(LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE))
FILENAME NAMELEN NEWNAME)
@@ -900,72 +902,74 @@
(LET [(FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE))
(FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE))
(ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE]
(AND (> FINFOID -1)
(< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
(CL:UNWIND-PROTECT
(CL:WHEN (> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE))
0)
(SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of
(CL:WHEN (AND (> FINFOID -1)
(< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)))
(CL:UNWIND-PROTECT
(CL:WHEN (> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE))
0)
(SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of
GENFILESTATE
)
0 NAMELEN))
)
0 NAMELEN))
(* ;; "NEWNAME and DIRECTORY are both UTF8")
(* ;;
 "NEWNAME and DIRECTORY are both in system format, and so is FILENAME here")
(SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY)
of GENFILESTATE)
NEWNAME
(fetch (UFSGENFILESTATE DEV) of GENFILESTATE))
)
(replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with FILENAME)
(COND
((= (add FILEID 1)
(fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
(SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY)
of GENFILESTATE)
NEWNAME
(fetch (UFSGENFILESTATE DEV) of GENFILESTATE)))
(replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with FILENAME)
(COND
((= (add FILEID 1)
(fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
(* ; "Generator exhausted. ")
(\UFS.UNREGISTER.GFS GENFILESTATE T))
(T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID)
))
(COND
((AND (EQ (CHARCODE >)
(NTHCHARCODE FILENAME -1))
(OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)
T)
(ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH)
of GENFILESTATE)
(fetch (UFSGENFILESTATE MAX-DEPTH) of
(\UFS.UNREGISTER.GFS GENFILESTATE T))
(T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID))
) (* ; "\GENERATEFILES operates in MCCS")
(COND
((AND (EQ (CHARCODE >)
(NTHCHARCODE FILENAME -1))
(OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)
T)
(ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH)
of GENFILESTATE)
(fetch (UFSGENFILESTATE MAX-DEPTH) of
GENFILESTATE
)))
[SETQ SUBGEN (\GENERATEFILES (CONCAT FILENAME
(FETCH (UFSGENFILESTATE
FILTER)
OF GENFILESTATE))
(CL:WHEN (fetch (UFSGENFILESTATE PROPP)
of GENFILESTATE)
)))
[SETQ SUBGEN (\GENERATEFILES
(SYSTOMSTRING (CONCAT FILENAME
(FETCH (UFSGENFILESTATE
FILTER)
OF GENFILESTATE)))
(CL:WHEN (fetch (UFSGENFILESTATE PROPP)
of GENFILESTATE)
(* ;;
(* ;;
 "Need any legal attributes to cause string allocation.")
'(SIZE CREATIONDATE AUTHOR))
'(SORT RESETLST]
(fetch (FILEGENOBJ GENFILESTATE) of SUBGEN))
'(SIZE CREATIONDATE AUTHOR))
'(SORT RESETLST]
(fetch (FILEGENOBJ GENFILESTATE) of SUBGEN))
(* ;; "It's a directory, so let's recurse into it.")
(* ;; "It's a directory, so let's recurse into it.")
(SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN))
(replace (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE
with SUBGEN)
(replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN
with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH)
of GENFILESTATE)))
(replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN
with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))
(SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN))
(replace (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE
with SUBGEN)
(replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN
with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) of
GENFILESTATE
)))
(replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN
with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))
(* ;; "We're set up to recurse into the SUBGEN above")
(* ;; "We're set up to recurse into the SUBGEN above")
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))
(NAMEONLY (UTF8TOMSTRING NEWNAME))
(T (UTF8TOMSTRING FILENAME))))
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))])
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))
(NAMEONLY (SYSTOMSTRING NEWNAME))
(T (SYSTOMSTRING FILENAME))))
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T))))])
(\UFS.FILEINFOFN
(LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 7-May-90 23:21 by nm") (* ;;; "FILEINFOFN for UFS--return the value of the specified ATTRIBUTE. ALLPROPS is fetched when a file is generated if GENERATEFILES method is invoked with some valid PROPs when the generator is created. ALLPROPS strucure is re-used. We have to be careful to COPY the values that come out.") (AND (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (CL:UNWIND-PROTECT (if (EQ ATTRIBUTE (QUOTE TYPE)) then (\UFSGetFileType (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) else (BLOCK) (SELECTQ ATTRIBUTE (LENGTH (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE))) (PROTECTION (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE PROTECTION) of GENFILESTATE))) (SIZE (FOLDHI (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE) BYTESPERPAGE)) ((CREATIONDATE WRITEDATE) (GDATE (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (READDATE (GDATE (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) ((ICREATIONDATE IWRITEDATE) (+ 0 (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (IREADDATE (+ 0 (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) (AUTHOR (* ; "Copy the string out of the buffer") (CL:SUBSEQ (fetch (UFSGENFILESTATE AUTHOR) of GENFILESTATE) 0 (fetch (UFSGENFILESTATE AULEN) of GENFILESTATE))) NIL)) (AND RESETSTATE (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (\UFS.UNREGISTER.GFS GENFILESTATE T)))))
@@ -1076,7 +1080,8 @@
(DEFINEQ
(CHDIR
[LAMBDA (PATHNAME) (* ; "Edited 16-Oct-2025 18:22 by rmk")
[LAMBDA (PATHNAME) (* ; "Edited 5-Feb-2026 18:31 by rmk")
(* ; "Edited 16-Oct-2025 18:22 by rmk")
(* ; "Edited 2-Apr-90 01:07 by nm")
(* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.")
@@ -1089,7 +1094,7 @@
(if (OR (EQ HOST 'DSK)
(EQ HOST 'UNIX))
then (if (SETQ PATH (DIRECTORYNAME PATH))
then (if (\UFSCHDIR-C (MTOUTF8STRING PATH))
then (if (\UFSCHDIR-C (MTOSYSSTRING PATH))
then (DIRECTORYNAME PATH)
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))
@@ -1557,23 +1562,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (9311 10864 (\UFSCreateDevice 9321 . 9686) (\UFS.CREATE.DEVICE 9688 . 10544) (
\UFSOpenDevice 10546 . 10723) (\UFSCloseDevice 10725 . 10862)) (15127 63821 (\UFSOpenFile 15137 .
21713) (\UFS.OPENP 21715 . 22212) (\UFS.RECOGNIZE.FILE 22214 . 23644) (\UFS.DIRECTORY.NAME 23646 .
24736) (\UFSCloseFile 24738 . 26797) (\UFSGetFileName 26799 . 26998) (\UFSDeleteFile 27000 . 28194) (
\UFSRenameFile 28196 . 30513) (\UFSReadPages 30515 . 31650) (\UFSWritePages 31652 . 32872) (
\UFSTruncateFile 32874 . 35280) (\UFSDirectoryNameP 35282 . 37145) (\UFSEventFn 37147 . 37809) (
\UFSGetFileInfo 37811 . 42274) (\UFS.CREATE.PROPS 42276 . 42629) (\UFSSetFileInfo 42631 . 44977) (
\UFSGenerateFiles 44979 . 52591) (\UFS.NEXTFILEFN 52593 . 60409) (\UFS.FILEINFOFN 60411 . 61860) (
\UFS.VALID.PROPP 61862 . 62154) (\UFS.REGISTER.GFS 62156 . 62411) (\UFS.UNREGISTER.GFS 62413 . 62996)
(\UFS.ABORT.DIRECTORY 62998 . 63346) (\UFS.ABORT.CL-DIRECTORY 63348 . 63635) (\UFS.CLEANUP.GFS.TABLE
63637 . 63819)) (63856 70540 (\UFSMakeUnixFormatName 63866 . 64887) (\UFSParseNameString 64889 . 65263
) (\UFSParse-Directory 65265 . 65806) (\UFS.PARSE.BODY 65808 . 66353) (\UFS.ADJUST.HOST 66355 . 66514)
(\UFS.FULLNAME 66516 . 67724) (\UFS.ADD.HOST.FIELD 67726 . 68086) (\UFS.REMOVE.HOST.FIELD 68088 .
69758) (\UFS.HANDLE.RELATIVEDIRECTORY 69760 . 70538)) (71356 72501 (CHDIR 71366 . 72499)) (72573 73559
(\DEVICEFILE.EOSERROR 72583 . 73557)) (73632 74869 (\UNVISIBLE.PAGED.REVALIDATEFILELST 73642 . 74487)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 74489 . 74867)) (74902 76528 (\UFSError 74912 . 76526)) (76572 78987 (
\UFSGetFileType 76582 . 77183) (\UFSSetFileType 77185 . 77782) (\UFSeol 77784 . 78985)) (87630 88754 (
\UFSGetPrintFileType 87640 . 88052) (\UFSGetFileTypeConfirm 88054 . 88502) (\UFSPrintTypeMenu 88504 .
88752)) (88784 91622 (\UFStoOtherCopyMess 88794 . 90472) (\UFStoOtherRenameMess 90474 . 91620)))))
(FILEMAP (NIL (8911 10464 (\UFSCreateDevice 8921 . 9286) (\UFS.CREATE.DEVICE 9288 . 10144) (
\UFSOpenDevice 10146 . 10323) (\UFSCloseDevice 10325 . 10462)) (14727 64649 (\UFSOpenFile 14737 .
21421) (\UFS.OPENP 21423 . 21920) (\UFS.RECOGNIZE.FILE 21922 . 23459) (\UFS.DIRECTORY.NAME 23461 .
24590) (\UFSCloseFile 24592 . 26759) (\UFSGetFileName 26761 . 26960) (\UFSDeleteFile 26962 . 28264) (
\UFSRenameFile 28266 . 30687) (\UFSReadPages 30689 . 31824) (\UFSWritePages 31826 . 33046) (
\UFSTruncateFile 33048 . 35562) (\UFSDirectoryNameP 35564 . 37617) (\UFSEventFn 37619 . 38281) (
\UFSGetFileInfo 38283 . 42853) (\UFS.CREATE.PROPS 42855 . 43208) (\UFSSetFileInfo 43210 . 45664) (
\UFSGenerateFiles 45666 . 53078) (\UFS.NEXTFILEFN 53080 . 61237) (\UFS.FILEINFOFN 61239 . 62688) (
\UFS.VALID.PROPP 62690 . 62982) (\UFS.REGISTER.GFS 62984 . 63239) (\UFS.UNREGISTER.GFS 63241 . 63824)
(\UFS.ABORT.DIRECTORY 63826 . 64174) (\UFS.ABORT.CL-DIRECTORY 64176 . 64463) (\UFS.CLEANUP.GFS.TABLE
64465 . 64647)) (64684 71368 (\UFSMakeUnixFormatName 64694 . 65715) (\UFSParseNameString 65717 . 66091
) (\UFSParse-Directory 66093 . 66634) (\UFS.PARSE.BODY 66636 . 67181) (\UFS.ADJUST.HOST 67183 . 67342)
(\UFS.FULLNAME 67344 . 68552) (\UFS.ADD.HOST.FIELD 68554 . 68914) (\UFS.REMOVE.HOST.FIELD 68916 .
70586) (\UFS.HANDLE.RELATIVEDIRECTORY 70588 . 71366)) (72184 73437 (CHDIR 72194 . 73435)) (73509 74495
(\DEVICEFILE.EOSERROR 73519 . 74493)) (74568 75805 (\UNVISIBLE.PAGED.REVALIDATEFILELST 74578 . 75423)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 75425 . 75803)) (75838 77464 (\UFSError 75848 . 77462)) (77508 79923 (
\UFSGetFileType 77518 . 78119) (\UFSSetFileType 78121 . 78718) (\UFSeol 78720 . 79921)) (88566 89690 (
\UFSGetPrintFileType 88576 . 88988) (\UFSGetFileTypeConfirm 88990 . 89438) (\UFSPrintTypeMenu 89440 .
89688)) (89720 92558 (\UFStoOtherCopyMess 89730 . 91408) (\UFStoOtherRenameMess 91410 . 92556)))))
STOP

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