From 198ce09b0d591ef82b3b9c10f70dae50d5380618 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Sat, 13 Feb 2021 09:01:21 -0800 Subject: [PATCH] files remade for init --- library/EXPORTS.ALL | 2 +- sources/ACODE.LCOM | Bin 19294 -> 19308 bytes sources/FASLOAD.LCOM | Bin 22348 -> 34132 bytes sources/FILEPKG | 2 +- sources/FILEPKG.LCOM | Bin 103352 -> 102592 bytes 5 files changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 sources/FASLOAD.LCOM diff --git a/library/EXPORTS.ALL b/library/EXPORTS.ALL index 18697a89..fcedfd7b 100644 --- a/library/EXPORTS.ALL +++ b/library/EXPORTS.ALL @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (LISPXPRIN1 "EXPORTS GATHERED FROM {DSK}larry>ilisp>medley>sources> ON 16-Jan-2021 22:50:43" T) (LISPXTERPRI T) (PUTPROP (QUOTE FILESETS) (QUOTE IMPORTDATE) (IDATE "29-Jan-1998 16:26:53")) (RPAQQ MODARITHMACROS (CEIL FLOOR FOLDHI FOLDLO MODUP UNFOLD MOD)) (PUTPROPS CEIL MACRO ((X N) (FLOOR (IPLUS X (CONSTANT (SUB1 N))) N))) (PUTPROPS FLOOR MACRO ((X N) (LOGAND X (CONSTANT (LOGXOR (SUB1 N) -1))))) (PUTPROPS FOLDHI MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR ( AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) (LIST (QUOTE IPLUS) FORM (SUB1 DIVISOR)) (SUB1 (INTEGERLENGTH DIVISOR))))))) (PUTPROPS FOLDLO MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR ( AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) FORM (SUB1 ( INTEGERLENGTH DIVISOR))))))) (PUTPROPS MODUP MACRO (OPENLAMBDA (X N) (IDIFFERENCE (SUB1 N) (IMOD (SUB1 X) N)))) (PUTPROPS UNFOLD MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR ( AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LLSH) FORM (SUB1 ( INTEGERLENGTH DIVISOR))))))) (PUTPROPS MOD MACRO (= . IMOD)) (RPAQQ BITSPERNIBBLE 4) (RPAQQ NIBBLESPERBYTE 2) (RPAQQ BITSPERBYTE 8) (RPAQQ BITSPERCELL 32) (RPAQQ BITSPERWORD 16) (RPAQQ BYTESPERCELL 4) (RPAQQ BYTESPERPAGE 512) (RPAQQ BYTESPERWORD 2) (RPAQQ CELLSPERPAGE 128) (RPAQQ CELLSPERSEGMENT 32768) (RPAQQ PAGESPERSEGMENT 256) (RPAQQ WORDSPERCELL 2) (RPAQQ WORDSPERPAGE 256) (RPAQQ WORDSPERSEGMENT 65536) (RPAQQ WORDSPERQUAD 4) (RPAQQ CELLSPERQUAD 2) (RPAQQ BYTESPERQUAD 8) (CONSTANTS BITSPERNIBBLE NIBBLESPERBYTE BITSPERBYTE BITSPERCELL BITSPERWORD BYTESPERCELL BYTESPERPAGE BYTESPERWORD CELLSPERPAGE CELLSPERSEGMENT PAGESPERSEGMENT WORDSPERCELL WORDSPERPAGE WORDSPERSEGMENT WORDSPERQUAD CELLSPERQUAD BYTESPERQUAD) (RPAQQ INTEGERSIZECONSTANTS ((BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP )) (MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP ( IDIFFERENCE -1 MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP ( LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 MAX.FIXP)))) (RPAQ BITS.PER.SMALLP (ADD1 BITSPERWORD)) (RPAQ SMALLP.LENGTH (SUB1 BITS.PER.SMALLP)) (RPAQ MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (RPAQ MIN.SMALLP (IDIFFERENCE -1 MAX.SMALLP)) (RPAQ BITS.PER.FIXP BITSPERCELL) (RPAQ FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (RPAQ MAX.FIXP (LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (RPAQ MIN.FIXP (IDIFFERENCE -1 MAX.FIXP)) (CONSTANTS (BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP)) (MAX.SMALLP ( LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP (IDIFFERENCE -1 MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP (LOGOR (LSH 1 ( SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 MAX.FIXP))) (PUTPROP (QUOTE MODARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:46:21")) (RPAQQ WINDFLG T) (CONSTANTS (WINDFLG T)) (RPAQQ INITCONSTANTS ((* |;;;| "(LISPNAME VALUE BCPLNAME UCODENAME)") (CDRCODING 1 T T) (* \; "IF CDRCODING=0, CDR CODING IS OFF, OTHERWISE ON") (* |;;| "type numbers -- repeated on LLBASIC too") (\\SMALLP 1 SMALLTYPE |SmallType|) (\\FIXP 2 INTEGERTYPE |FixpType|) (\\FLOATP 3 FLTPTTYPE |FloatpType|) (\\LITATOM 4 ATOMTYPE |AtomType|) (\\LISTP 5 LISTTYPE |ListType|) (\\ARRAYP 6 ARRAYPTRTYPE |ArrayType|) (\\STRINGP 7 STRINGPTRTYPE) (\\STACKP 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10 NIL |VMemPagePType|) (\\STREAM 11 NIL STREAMTYPE) (* |;;| "TYPE TABLE CONSTANTS - - - - - - - - - - - - - - - - - - - - - -") (\\TT.TYPEMASK 2047 |TTTypeMask| T ) (\\TT.NOREF 32768 NIL T) (\\TT.SYMBOLP 16384 NIL T) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 2048) (* |;;| "page map - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -") (|\\PMblockSize| 32 PMBLOCKSIZE) (|\\STATSsize| 8 T) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535 T) ( |\\FirstVmemBlock| 2 T) (\\MAXVMPAGE 131069) (\\MAXVMSEGMENT 255) (* |;;| "interface page") ( |\\IFPValidKey| 5603 T) (* |;;| "MDS") (|\\FirstMDSPage| 16382) (|\\MaxMDSPage| 524285) ( |\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512) (|\\PagesPerMDSUnit| 2) (* \; "(FOLDLO \\MDSIncrement WORDSPERPAGE)") (* |;;| "arrays") (\\ARRAYSPACE (46 0)) (|\\FirstArraySegment| 46) (|\\FirstArrayPage| 11776) (\\ARRAYSPACE2 (64 0)) (|\\DefaultSecondArrayPage| 16384) (* |;;| "stack block constants") (|\\StackMask| 57344 T T) (|\\FxtnBlock| 49152 T T) (|\\GuardBlock| 57344 T T ) (|\\BFBlock| 32768 T T) (|\\FreeStackBlock| 40960 T T) (|\\NotStackBlock| 0) (* \; "none of the above") (|\\MinExtraStackWords| 32 T T) (* |;;| "backspace kludge") (ERASECHARCODE 0 T) ( * |;;| "GC constants") (\\HT1CNT 1024 NIL T) (\\HTSTKBIT 512 NIL T) (\\HTCNTMASK 64512 NIL T) ( \\HTMAINSIZE 65536 NIL T) (\\HTCOLLSIZE 1048576 NIL T) (* \; "HTCOLL size in words") (\\HTENDFREE 1 NIL T) (\\HTFREEPTR 0 NIL T) (* |;;| "pointers and lengths of various data spaces") (\\ATOMSPACE (0 0) (|ATOMspace| NIL) (|atomHiVal| NIL)) (|\\AtomHI| 0) (\\CHARHI 7) (* \; "overlap character space and the atom hash table space") (|\\AtomHashTable| (21 0) (|AHTspace| |AHTbase|)) (|\\AtomHTpages| 256 AHTSIZE) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) ( \\SMALLPOSPSPACE (14 0)) (|\\SmallPosHi| 14 |SMALLPOSspace| |smallpl|) (\\SMALLNEGSPACE (15 0)) ( |\\SmallNegHi| 15 |SMALLNEGspace| |smallneg|) (|\\NumSmallPages| 512) (* |;;| "PNAME SPACEin the old world; used for initial atoms now.") (\\PNPSPACE (8 0) (|PNPspace| |PNPbase|)) (\\PNAME.HI 8) (\\OLDATOMSPACE (44 0)) (* \; "NEW ATOM SPACE") (\\ATOM.HI 44) (* \; "HI PART OF NEW ATOM SPACE") (* |;;| "Definitions in old atom world") (\\DEFSPACE (10 0) (|DEFspace| |DEFbase|) (|DEFspace| |DEFbase|)) (\\DEF.HI 10) (\\VALSPACE (12 0) (|TOPVALspace| |TOPVALbase|) ( |VALspace| |VALbase|)) (\\VAL.HI 12) (\\PLISTSPACE (2 0) (|PLISTspace| |PLISTbase|)) (\\PLIST.HI 2) ( \\PAGEMAP (5 0) (|PAGEMAPspace| |PAGEMAPbase|)) (|\\NumPageMapPages| 256) (|\\PageMapTBL| (20 512) ( |PMTspace| |PMTbase|)) (|\\InterfacePage| (20 0) (|INTERFACEspace| |INTERFACEbase|) (|INTERFACEspace| |INTERFACEbase|)) (\\IOPAGE (0 65280)) (|\\DoveIORegion| (0 16384)) (\\IOCBPAGE (0 256)) (\\FPTOVP (2 0)) (|\\MDSTypeTable| (24 0) (|MDSTYPEspace| |MDSTYPEbase|) (|MDSTYPEspace| |MDSTYPEbase|)) ( |\\MDSTTsize| 1024 T) (* \; "in Pages") (\\MISCSTATS (20 2560) (|STATSspace| |MISCSTATSbase|)) ( |\\UFNTable| (20 3072) NIL (|STATSspace| |UFNTablebase|)) (|\\UFNTableSize| 2) (|\\DTDSpaceBase| (20 4096) (|DTDspace| |DTDbase|) (|DTDspace| |DTDbase|)) (|\\DTDSize| 18 T) (\\LISTPDTD (20 4186)) ( |\\EndTypeNumber| 2047) (\\LOCKEDPAGETABLE (20 28672)) (|\\NumLPTPages| 16) (\\STACKSPACE (1 0) ( |STACKspace| NIL) (|STACKspace| NIL)) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 1 T T) (\\HTMAIN (22 0) (|HTMAINspace| |HTMAINbase|) (|HTMAINspace| |HTMAINbase|)) (|\\HTMAINnpages| 256 T) (\\HTOVERFLOW (23 0) NIL (NIL |HTOVERFLOWbase|)) (\\HTBIGCOUNT (23 32768)) (\\HTCOLL (28 0) NIL (|HTCOLLspace| |HTCOLLbase|)) (\\DISPLAYREGION (18 0)) (|\\D1BCPLspace| 0 T |LEmubrHiVal|) ( |\\D0BCPLspace| 0 T) (* |;;| "Interface Page locations") (|\\CurrentFXP| 0 T T) (|\\ResetFXP| 1 T T) ( |\\SubovFXP| 2 T T) (|\\KbdFXP| 3 T T) (|\\HardReturnFXP| 4 T T) (\\GCFXP 5) (\\FAULTFXP 6 T T) ( |\\MiscFXP| 14 T T) (|\\TeleRaidFXP| 24 T T) (* |;;| "emulator segment locations") (DCB.EM 272) ( DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (KBDAD1.EM 65053) (KBDAD2.EM 65054) ( KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) ( |\\LispKeyMask| 8192 T T) (|\\BcplKeyMask| 4352 T T) (* \; "Machine types") (\\MAIKO 3) (\\DOLPHIN 4) (\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (* |;;| "FOR DLION (AND DAYBREAK)") (\\VP.DISPLAY 4608) ( \\NP.DISPLAY 202) (* \; "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)") ( \\NP.WIDEDOVEDISPLAY 243) (* \; "Wide Dove display 1152x864 pixels") (\\WIDEDOVEDISPLAYWIDTH 1152) ( \\RP.AFTERDISPLAY 206) (* \; "Includes 4 pages for cursor") (\\RP.AFTERDOVEDISPLAY 243) (* \; "if big screen") (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (* \; "(+ \\RP.TEMPDISPLAY \\NP.WIDEDOVEDISPLAY)") (\\RP.STACK 768) (\\VP.STACK 256) (\\RP.MAP 256) ( \\NP.MAP 256) (\\RP.IOPAGE 512) (* \; "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range") (\\RP.DOVEIOCBPAGE 543) ( \\RP.DOVEIORGN 544) (\\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 5120) ( \\VP.FPTOVP 512) (\\NP.FPTOVP 4096) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 6144) ( \\NP.TYPETABLE 1024) (\\RP.TYPETABLE 5120) (\\VP.GCTABLE 5632) (\\NP.GCTABLE 256) (\\RP.GCTABLE 6144) (\\VP.GCOVERFLOW 5888) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 6400) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) ( \\VP.PRIMARYMAP 5122) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 5232) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) ( \\VP.BUFFERS 218) (* \; "DLion processor commands") (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) ( \\DL.READTOD 32770) (\\DL.READPID 32771) (\\DL.BOOTBUTTON 32772))) (RPAQQ MISCSTATSLAYOUT ((STARTTIME FIXP |MSstrtTime|) (TOTALTIME FIXP) (SWAPWAITTIME FIXP T) ( PAGEFAULTS FIXP T) (SWAPWRITES FIXP T) (DISKIOTIME FIXP T) (DISKOPS FIXP T) (KEYBOARDWAITTIME FIXP T) (GCTIME FIXP T) (NETIOTIME FIXP T) (NETIOOPS FIXP T) (SWAPTEMP0 FIXP) (SWAPTEMP1 FIXP) (RCLKSECOND FIXP) (SECONDSCLOCK FIXP) (MILLISECONDSCLOCK FIXP) (BASECLOCK FIXP) (RCLKTEMP0 FIXP) (SECONDSTMP FIXP) (MILLISECONDSTMP FIXP) (BASETMP FIXP) (EXCESSTIMETMP FIXP) (CLOCKTEMP0 FIXP) (DISKTEMP0 FIXP) ( DISKTEMP1 FIXP) (TELERAIDTEMP1 FIXP) (TELERAIDTEMP2 FIXP) (TELERAIDTEMP3 FIXP) (LASTUSERACTION FIXP) ( DLMOUSETIMER FIXP) (DLMOUSETEMP FIXP))) (RPAQQ IFPAGELAYOUT ((|CurrentFXP| WORD) (* \; "First 7 items are FX values for user and 6 system contexts.") (|ResetFXP| WORD) (|SubovFXP| WORD) ( |KbdFXP| WORD) (|HardReturnFXP| WORD) (GCFXP WORD) (FAULTFXP WORD) (|EndOfStack| WORD) (* \; "Stack high-water mark: address of guard block at current end of stack") (|LVersion| WORD) (* \; "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp") ( |MinRVersion| WORD) (|MinBVersion| WORD) (|RVersion| WORD) (* \; "Bcpl fills in the actual microcode, Bcpl versions.") (|BVersion| WORD) (|MachineType| WORD) ( |MiscFXP| WORD) (* \; "FX for MISC context") (|Key| WORD) (* \; "= IFPValidKey if vmem consistent.") ( |SerialNumber| WORD) (* \; "Pup host number (Dorado/Dolphin)") (|EmulatorSpace| WORD) (* \; "Hiloc of bcpl space (always zero now)") (|ScreenWidth| WORD) (|NxtPMAddr| WORD) (* \; "Next page to be allocated in secondary page map table") (|NActivePages| WORD) (* \; "Length of vmem in use") (|NDirtyPages| WORD) (* \; "not used, but maintained as = NActivePages") ( |filePnPMP0| WORD) (* \; "Sysout page number of first page of secondary page map table (\\PAGEMAP), which is where the secondary map pages themselves live" ) (|filePnPMT0| WORD) (* \; "Sysout page number of first page of primary page map table") (TELERAIDFXP WORD) (* \; "FX for TeleRaid server context") (NATIVE-START-MEM-PAGE WORD) (* \; "Unix page where native code starts") (NATIVE-LENGTH-PAGE WORD) (* \; "Unix page length of native code") (NATIVE-PAGE-OFFSET WORD) (* \; "Lisp Disk Page offset of native code") (|UserNameAddr| WORD) (* \; "Addresses in bcpl space (seg 0) of global user name and password") (|UserPswdAddr| WORD) (|StackBase| WORD) (* \; "Stack address where user stack starts") (FAULTHI WORD) (* \; "Microcode for page fault stores fault address here, then does context switch to FAULTFXP") (FAULTLO WORD) (DEVCONFIG WORD) (* \; "IT'S FOR KB,DISP TYPE") (* \; "Formerly REALPAGETABLE, back when it was always in Bcpl space.") (RPTSIZE WORD) (* \; "Number of entries in Real Page Table") (RPOFFSET WORD) (* \; "RP-RPOFFSET => index in table") ( MAXETHERBYTES WORD) (* \; "Number of bytes available in a pbi, not counting encapsulation (Dorado)") ( EMBUFVP WORD) (* \; "VP of a one-page emulator buffer") (|NSHost0| WORD) (* \; "Machine's 48-bit NS host number. Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in." ) (|NSHost1| WORD) (|NSHost2| WORD) (|MDSZone| WORD) (* \; "Obsolete -- was used by Dolphin 10MB network code.") (|MDSZoneLength| WORD) (EMUBUFFERS WORD) (* \; "Buffer space in segment 0 for swapping/disk activity") (EMUBUFLENGTH WORD) (* \; "Number of words of said space") (LASTNUMCHARS WORD) (* \; "No longer used?") (SYSDISK WORD) (* \; "Address of sysDisk in Bcpl space -- disk obj for boot partition.") (ISFMAP WORD) (* |;;| "The following 4 are for \\MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!" ) (MISCSTACKFN FULLXPOINTER) (MISCSTACKARG1 FULLXPOINTER) (MISCSTACKARG2 FULLXPOINTER) ( MISCSTACKRESULT FULLXPOINTER) (|NRealPages| WORD) (* \; "Number pages of real memory") ( |LastLockedFilePage| WORD) (* \; "Last page of vmem that is locked--booting has to load at least that far.") (|LastDominoFilePage| WORD ) (* \; "Last sysout page reserved for Dandelion microcode") (|FPTOVPStart| WORD) (* \; "Sysout page where FPTOVP starts") (FAKEMOUSEBITS WORD) (* \; "Used to implement fake middle button on 2-button Dandelion.") (|DL24BitAddressable| WORD) (* \; "non-zero if DLion capable of addressing 32MB virtual memory") (REALPAGETABLEPTR FULLXPOINTER) (* \; "Address of real page table, set up by Bcpl (but not chained together)") (|DLLastVmemPage| WORD) (* \; "DLion booting microcode puts length of vmem file here.") (|FullSpaceUsed| WORD) (* \; "Non-zero if vmem beyond initial 8MB has been allocated.") (FAKEKBDAD4 WORD) (FAKEKBDAD5 WORD) (* |;;| "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with." ) (|XVmemFmapBase| WORD) (* \; "Bcpl stores isf map pointer to each partition here. First is redundant with ISFMAP field above.") ( NIL WORD) (NIL WORD) (|XVmemFmapHighBase| WORD) (* \; "Bcpl stores the highest vm page contained in this or earlier partition.") (NIL WORD) (NIL WORD) ( |XVmemDiskBase| FULLXPOINTER) (* \; "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).") (NIL FULLXPOINTER) (NIL FULLXPOINTER))) (RPAQQ MAIKO.IFPAGELAYOUT ((|CurrentFXP| WORD) (* \; "First 7 items are FX values for user and 6 system contexts.") (|ResetFXP| WORD) (|SubovFXP| WORD) ( |KbdFXP| WORD) (|HardReturnFXP| WORD) (GCFXP WORD) (FAULTFXP WORD) (|EndOfStack| WORD) (* \; "Stack high-water mark: address of guard block at current end of stack") (|LVersion| WORD) (* \; "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp") ( |MinRVersion| WORD) (|MinBVersion| WORD) (|RVersion| WORD) (* \; "Bcpl fills in the actual microcode, Bcpl versions.") (|BVersion| WORD) (|MachineType| WORD) ( |MiscFXP| WORD) (* \; "FX for MISC context") (|Key| WORD) (* \; "= IFPValidKey if vmem consistent.") ( |SerialNumber| WORD) (* \; "Pup host number (Dorado/Dolphin)") (|EmulatorSpace| WORD) (* \; "Hiloc of bcpl space (always zero now)") (|ScreenWidth| WORD) (|NxtPMAddr| WORD) (* \; "Next page to be allocated in secondary page map table") (NIL WORD) (* \; "WAS NActivePages, Length of vmem in use") (NIL WORD) (* \; "WAS NDirtyPages, not used, but maintained as = NActivePages") (|filePnPMP0| WORD) (* \; "Sysout page number of first page of secondary page map table (\\PAGEMAP), which is where the secondary map pages themselves live" ) (|filePnPMT0| WORD) (* \; "Sysout page number of first page of primary page map table") (TELERAIDFXP WORD) (* \; "FX for TeleRaid server context") (NATIVE-START-MEM-PAGE WORD) (* \; "Unix page where native code starts") (NATIVE-LENGTH-PAGE WORD) (* \; "Unix page length of native code") (NATIVE-PAGE-OFFSET WORD) (* \; "Lisp Disk Page offset of native code") (|UserNameAddr| WORD) (* \; "Addresses in bcpl space (seg 0) of global user name and password") (|UserPswdAddr| WORD) (|StackBase| WORD) (* \; "Stack address where user stack starts") (FAULTHI WORD) (* \; "Microcode for page fault stores fault address here, then does context switch to FAULTFXP") (FAULTLO WORD) (DEVCONFIG WORD) (* \; "IT'S FOR KB,DISP TYPE") (* \; "Formerly REALPAGETABLE, back when it was always in Bcpl space.") (RPTSIZE WORD) (* \; "Number of entries in Real Page Table") (RPOFFSET WORD) (* \; "RP-RPOFFSET => index in table") ( MAXETHERBYTES WORD) (* \; "Number of bytes available in a pbi, not counting encapsulation (Dorado)") ( EMBUFVP WORD) (* \; "VP of a one-page emulator buffer") (|NSHost0| WORD) (* \; "Machine's 48-bit NS host number. Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in." ) (|NSHost1| WORD) (|NSHost2| WORD) (|MDSZone| WORD) (* \; "Obsolete -- was used by Dolphin 10MB network code.") (|MDSZoneLength| WORD) (EMUBUFFERS WORD) (* \; "Buffer space in segment 0 for swapping/disk activity") (EMUBUFLENGTH WORD) (* \; "Number of words of said space") (* |;;| "The following 2 are available if NEW_STOARGE is specified in C") (|ProcessSize| WORD) (* \; "Process size for which can be use as LISP space") (|StorageFullState| WORD) (* \; "Save last storage state") (ISFMAP WORD) (* |;;| "The following 4 are for \\MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!" ) (MISCSTACKFN FULLXPOINTER) (MISCSTACKARG1 FULLXPOINTER) (MISCSTACKARG2 FULLXPOINTER) ( MISCSTACKRESULT FULLXPOINTER) (|NRealPages| WORD) (* \; "Number pages of real memory") ( |LastLockedFilePage| WORD) (* \; "Last page of vmem that is locked--booting has to load at least that far.") (|LastDominoFilePage| WORD ) (* \; "Last sysout page reserved for Dandelion microcode") (|FPTOVPStart| WORD) (* \; "Sysout page where FPTOVP starts") (FAKEMOUSEBITS WORD) (* \; "Used to implement fake middle button on 2-button Dandelion.") (|DL24BitAddressable| WORD) (* \; "non-zero if DLion capable of addressing 32MB virtual memory") (REALPAGETABLEPTR FULLXPOINTER) (* \; "Address of real page table, set up by Bcpl (but not chained together)") (SYSDISK WORD) (* \; "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.") (|FullSpaceUsed| WORD) ( * \; "Non-zero if vmem beyond initial 8MB has been allocated.") (FAKEKBDAD4 WORD) (FAKEKBDAD5 WORD) (* |;;| "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with." ) (|XVmemFmapBase| WORD) (* \; "Bcpl stores isf map pointer to each partition here. First is redundant with ISFMAP field above.") ( NIL WORD) (NIL WORD) (|XVmemFmapHighBase| WORD) (* \; "Bcpl stores the highest vm page contained in this or earlier partition.") (NIL WORD) (NIL WORD) ( |XVmemDiskBase| FULLXPOINTER) (* \; "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).") (NIL FULLXPOINTER) (NIL FULLXPOINTER) (|DLLastVmemPage| FIXP) (* \; "DLion booting microcode puts length of vmem file here.") (|NActivePages| FIXP) (* \; "Length of vmem in use") (|NDirtyPages| FIXP) (* \; "not used, but maintained as = NActivePages"))) (RPAQQ IOPAGELAYOUT ((NIL 18 WORD) (DLMAINTPANEL WORD NIL T) (DLFLOPPYCMD WORD) (DLTTYPORTCMD WORD) ( DLPROCESSORCMD WORD) (NEWMOUSESTATE WORD) (DLBEEPCMD WORD) (DLRS232CMISCCOMMAND WORD) (DLRS232CPUTFLAG WORD) (DLRS232CGETFLAG WORD) (NIL 6 WORD) (DLFLOPPY WORD) (DLTTYOUT WORD) (NIL 1 WORD) (DLTTYIN WORD) (NIL 1 WORD) (DLPROCESSOR2 WORD) (DLPROCESSOR1 WORD) (DLPROCESSOR0 WORD) (NEWMOUSEX WORD) (NEWMOUSEY WORD) (DLBEEPFREQ WORD) (DLRS232CPARAMETERCSBLO WORD) (DLRS232CPARAMETERCSBHI WORD) ( DLRS232CSETRS366STATUS 3 WORD) (DLRS232CPUTCSBLO WORD) (DLRS232CPUTCSBHI WORD) (DLRS232CGETCSBLO WORD) (DLRS232CGETCSBHI WORD) (DLRS232CDEVICESTATUS WORD) (DLRS232CPARAMETEROUTCOME WORD) (DLTODVALID WORD) (DLTODLO WORD NIL T) (DLTODHI WORD) (DLTODLO2 WORD) (DLMOUSEX WORD NIL T) (DLMOUSEY WORD NIL T) ( DLUTILIN WORD NIL T) (DLKBDAD0 WORD NIL T) (DLKBDAD1 WORD NIL T) (DLKBDAD2 WORD NIL T) (DLKBDAD3 WORD NIL T) (DLKBDAD4 WORD NIL T) (DLKBDAD5 WORD NIL T) (DLLSEPIMAGECSB 32 WORD) (DLIOPHARDWARECONFIG WORD) (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) (DLRS232CPARAMETERCSBHI.11 WORD) ( DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) (DLETHERNET 12 WORD NIL T) (NIL 31 WORD) (DLDISPINTERRUPT WORD NIL T) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) (DLCURSORX WORD NIL T) ( DLCURSORY WORD NIL T) (DLCURSORBITMAP 16 WORD NIL T))) (RPAQQ CDRCODING 1) (RPAQQ \\SMALLP 1) (RPAQQ \\FIXP 2) (RPAQQ \\FLOATP 3) (RPAQQ \\LITATOM 4) (RPAQQ \\LISTP 5) (RPAQQ \\ARRAYP 6) (RPAQQ \\STRINGP 7) (RPAQQ \\STACKP 8) (RPAQQ \\CHARACTERP 9) (RPAQQ \\VMEMPAGEP 10) (RPAQQ \\STREAM 11) (RPAQQ \\TT.TYPEMASK 2047) (RPAQQ \\TT.NOREF 32768) (RPAQQ \\TT.SYMBOLP 16384) (RPAQQ \\TT.FIXP 8192) (RPAQQ \\TT.NUMBERP 4096) (RPAQQ \\TT.ATOM 2048) (RPAQQ |\\PMblockSize| 32) (RPAQQ |\\STATSsize| 8) (RPAQQ |\\NumPMTpages| 8) (RPAQQ |\\EmptyPMTEntry| 65535) (RPAQQ |\\FirstVmemBlock| 2) (RPAQQ \\MAXVMPAGE 131069) (RPAQQ \\MAXVMSEGMENT 255) (RPAQQ |\\IFPValidKey| 5603) (RPAQQ |\\FirstMDSPage| 16382) (RPAQQ |\\MaxMDSPage| 524285) (RPAQQ |\\DefaultSecondMDSPage| 65532) (RPAQQ |\\MDSIncrement| 512) (RPAQQ |\\PagesPerMDSUnit| 2) (RPAQQ |\\FirstArraySegment| 46) (RPAQQ |\\FirstArrayPage| 11776) (RPAQQ |\\DefaultSecondArrayPage| 16384) (RPAQQ |\\StackMask| 57344) (RPAQQ |\\FxtnBlock| 49152) (RPAQQ |\\GuardBlock| 57344) (RPAQQ |\\BFBlock| 32768) (RPAQQ |\\FreeStackBlock| 40960) (RPAQQ |\\NotStackBlock| 0) (RPAQQ |\\MinExtraStackWords| 32) (RPAQQ ERASECHARCODE 0) (RPAQQ \\HT1CNT 1024) (RPAQQ \\HTSTKBIT 512) (RPAQQ \\HTCNTMASK 64512) (RPAQQ \\HTMAINSIZE 65536) (RPAQQ \\HTCOLLSIZE 1048576) (RPAQQ \\HTENDFREE 1) (RPAQQ \\HTFREEPTR 0) (RPAQQ |\\AtomHI| 0) (RPAQQ \\CHARHI 7) (RPAQQ |\\AtomHTpages| 256) (RPAQQ |\\LastAtomPage| 255) (RPAQQ |\\MaxAtomFrLst| 65535) (RPAQQ |\\SmallPosHi| 14) (RPAQQ |\\SmallNegHi| 15) (RPAQQ |\\NumSmallPages| 512) (RPAQQ \\PNAME.HI 8) (RPAQQ \\ATOM.HI 44) (RPAQQ \\DEF.HI 10) (RPAQQ \\VAL.HI 12) (RPAQQ \\PLIST.HI 2) (RPAQQ |\\NumPageMapPages| 256) (RPAQQ |\\MDSTTsize| 1024) (RPAQQ |\\UFNTableSize| 2) (RPAQQ |\\DTDSize| 18) (RPAQQ |\\EndTypeNumber| 2047) (RPAQQ |\\NumLPTPages| 16) (RPAQQ |\\GuardStackAddr| 61440) (RPAQQ |\\LastStackAddr| 65534) (RPAQQ \\STACKHI 1) (RPAQQ |\\HTMAINnpages| 256) (RPAQQ |\\D1BCPLspace| 0) (RPAQQ |\\D0BCPLspace| 0) (RPAQQ |\\CurrentFXP| 0) (RPAQQ |\\ResetFXP| 1) (RPAQQ |\\SubovFXP| 2) (RPAQQ |\\KbdFXP| 3) (RPAQQ |\\HardReturnFXP| 4) (RPAQQ \\GCFXP 5) (RPAQQ \\FAULTFXP 6) (RPAQQ |\\MiscFXP| 14) (RPAQQ |\\TeleRaidFXP| 24) (RPAQQ DCB.EM 272) (RPAQQ DISPINTERRUPT.EM 273) (RPAQQ CURSORBITMAP.EM 281) (RPAQQ KBDAD0.EM 65052) (RPAQQ KBDAD1.EM 65053) (RPAQQ KBDAD2.EM 65054) (RPAQQ KBDAD3.EM 65055) (RPAQQ UTILIN.EM 65048) (RPAQQ CURSORX.EM 278) (RPAQQ CURSORY.EM 279) (RPAQQ MOUSEX.EM 276) (RPAQQ MOUSEY.EM 277) (RPAQQ |\\LispKeyMask| 8192) (RPAQQ |\\BcplKeyMask| 4352) (RPAQQ \\MAIKO 3) (RPAQQ \\DOLPHIN 4) (RPAQQ \\DORADO 5) (RPAQQ \\DANDELION 6) (RPAQQ \\DAYBREAK 8) (RPAQQ \\VP.DISPLAY 4608) (RPAQQ \\NP.DISPLAY 202) (RPAQQ \\NP.WIDEDOVEDISPLAY 243) (RPAQQ \\WIDEDOVEDISPLAYWIDTH 1152) (RPAQQ \\RP.AFTERDISPLAY 206) (RPAQQ \\RP.AFTERDOVEDISPLAY 243) (RPAQQ \\RP.DISPLAY 0) (RPAQQ \\RP.TEMPDISPLAY 2561) (RPAQQ \\RP.MISCLOCKED 2804) (RPAQQ \\RP.STACK 768) (RPAQQ \\VP.STACK 256) (RPAQQ \\RP.MAP 256) (RPAQQ \\NP.MAP 256) (RPAQQ \\RP.IOPAGE 512) (RPAQQ \\RP.DOVEIOCBPAGE 543) (RPAQQ \\RP.DOVEIORGN 544) (RPAQQ \\VP.DOVEIORGN 64) (RPAQQ \\DOVEIORGNSIZE 64) (RPAQQ \\VP.IOPAGE 255) (RPAQQ \\VP.IFPAGE 5120) (RPAQQ \\VP.FPTOVP 512) (RPAQQ \\NP.FPTOVP 4096) (RPAQQ \\RP.FPTOVP 1024) (RPAQQ \\RP.STARTBUFFERS 640) (RPAQQ \\VP.TYPETABLE 6144) (RPAQQ \\NP.TYPETABLE 1024) (RPAQQ \\RP.TYPETABLE 5120) (RPAQQ \\VP.GCTABLE 5632) (RPAQQ \\NP.GCTABLE 256) (RPAQQ \\RP.GCTABLE 6144) (RPAQQ \\VP.GCOVERFLOW 5888) (RPAQQ \\NP.GCOVERFLOW 1) (RPAQQ \\RP.GCOVERFLOW 6400) (RPAQQ \\FP.IFPAGE 2) (RPAQQ \\VP.IOCBS 1) (RPAQQ \\VP.PRIMARYMAP 5122) (RPAQQ \\VP.SECONDARYMAP 1280) (RPAQQ \\VP.LPT 5232) (RPAQQ \\VP.INITSCRATCH 8) (RPAQQ \\VP.RPT 128) (RPAQQ \\VP.BUFFERS 218) (RPAQQ \\DL.PROCESSORBUSY 32768) (RPAQQ \\DL.SETTOD 32769) (RPAQQ \\DL.READTOD 32770) (RPAQQ \\DL.READPID 32771) (RPAQQ \\DL.BOOTBUTTON 32772) (CONSTANTS (CDRCODING 1) (\\SMALLP 1) (\\FIXP 2) (\\FLOATP 3) (\\LITATOM 4) (\\LISTP 5) (\\ARRAYP 6) ( \\STRINGP 7) (\\STACKP 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10) (\\STREAM 11) (\\TT.TYPEMASK 2047) ( \\TT.NOREF 32768) (\\TT.SYMBOLP 16384) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 2048) ( |\\PMblockSize| 32) (|\\STATSsize| 8) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535) ( |\\FirstVmemBlock| 2) (\\MAXVMPAGE 131069) (\\MAXVMSEGMENT 255) (|\\IFPValidKey| 5603) ( |\\FirstMDSPage| 16382) (|\\MaxMDSPage| 524285) (|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512 ) (|\\PagesPerMDSUnit| 2) (|\\FirstArraySegment| 46) (|\\FirstArrayPage| 11776) ( |\\DefaultSecondArrayPage| 16384) (|\\StackMask| 57344) (|\\FxtnBlock| 49152) (|\\GuardBlock| 57344) ( |\\BFBlock| 32768) (|\\FreeStackBlock| 40960) (|\\NotStackBlock| 0) (|\\MinExtraStackWords| 32) ( ERASECHARCODE 0) (\\HT1CNT 1024) (\\HTSTKBIT 512) (\\HTCNTMASK 64512) (\\HTMAINSIZE 65536) ( \\HTCOLLSIZE 1048576) (\\HTENDFREE 1) (\\HTFREEPTR 0) (|\\AtomHI| 0) (\\CHARHI 7) (|\\AtomHTpages| 256 ) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) (|\\SmallPosHi| 14) (|\\SmallNegHi| 15) ( |\\NumSmallPages| 512) (\\PNAME.HI 8) (\\ATOM.HI 44) (\\DEF.HI 10) (\\VAL.HI 12) (\\PLIST.HI 2) ( |\\NumPageMapPages| 256) (|\\MDSTTsize| 1024) (|\\UFNTableSize| 2) (|\\DTDSize| 18) (|\\EndTypeNumber| 2047) (|\\NumLPTPages| 16) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 1) ( |\\HTMAINnpages| 256) (|\\D1BCPLspace| 0) (|\\D0BCPLspace| 0) (|\\CurrentFXP| 0) (|\\ResetFXP| 1) ( |\\SubovFXP| 2) (|\\KbdFXP| 3) (|\\HardReturnFXP| 4) (\\GCFXP 5) (\\FAULTFXP 6) (|\\MiscFXP| 14) ( |\\TeleRaidFXP| 24) (DCB.EM 272) (DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) ( KBDAD1.EM 65053) (KBDAD2.EM 65054) (KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) (|\\LispKeyMask| 8192) (|\\BcplKeyMask| 4352) (\\MAIKO 3) ( \\DOLPHIN 4) (\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (\\VP.DISPLAY 4608) (\\NP.DISPLAY 202) ( \\NP.WIDEDOVEDISPLAY 243) (\\WIDEDOVEDISPLAYWIDTH 1152) (\\RP.AFTERDISPLAY 206) (\\RP.AFTERDOVEDISPLAY 243) (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (\\RP.STACK 768) (\\VP.STACK 256 ) (\\RP.MAP 256) (\\NP.MAP 256) (\\RP.IOPAGE 512) (\\RP.DOVEIOCBPAGE 543) (\\RP.DOVEIORGN 544) ( \\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 5120) (\\VP.FPTOVP 512) ( \\NP.FPTOVP 4096) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 6144) (\\NP.TYPETABLE 1024) (\\RP.TYPETABLE 5120) (\\VP.GCTABLE 5632) (\\NP.GCTABLE 256) (\\RP.GCTABLE 6144) ( \\VP.GCOVERFLOW 5888) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 6400) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) ( \\VP.PRIMARYMAP 5122) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 5232) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) ( \\VP.BUFFERS 218) (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) (\\DL.READTOD 32770) (\\DL.READPID 32771) (\\DL.BOOTBUTTON 32772)) (RPAQQ \\MPERRORS ((\\MP.OBSOLETEVMEM 1) (\\MP.INVALIDVMEM 2 "Vmem inconsistent at startup") ( \\MP.IOCBPAGE 3 "No place for IOCB page at startup") (\\MP.MOB 4 "Map out of bounds") ( \\MP.INVALIDADDR 5) (\\MP.INVALIDVP 6) (\\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain") (\\MP.SELECTLOOP 8 "Loop in \\SELECTREALPAGE") ( \\MP.NEWPAGE 9 "Attempt to allocate already existing page") (\\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page") (\\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another") (\\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box") (\\MP.RESIDENT 13 "Fault on resident page") (\\MP.STACKFAULT 14 "Fault on stack") (\\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") ( \\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code") (\\MP.STACKFULL 19) (\\MP.MDSFULL 20) (\\MP.UNKNOWN.UFN 21) ( \\MP.ATOMSFULL 22) (\\MP.PNAMESFULL 23) (\\MP.USECOUNTOVERFLOW 24) (\\MP.MDSFULLWARNING 25) ( \\MP.BADMDSFREELIST 26) (\\MP.BADARRAYBLOCK 27) (\\MP.BADDELETEBLOCK 28) (\\MP.BADARRAYRECLAIM 29) ( \\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") ( \\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\\MP.DELREF0 32) (\\MP.PROCERROR 33) (\\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\\MP.32MBINUSE 35) (\\MP.TOPUNWOUND 36 "Unexpected (RETTO T)") (\\MP.STACKRELEASED 37) (\\MP.FLUSHLOCKED 38) (\\MP.MAPNOTLOCKED 39) ( \\MP.UNLOCKINGMAP 40) (\\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\\MP.BADRUNTABLE 42 "Malformed run table for vmem file"))) (RPAQQ \\MP.OBSOLETEVMEM 1) (RPAQ \\MP.INVALIDVMEM 2 "Vmem inconsistent at startup") (RPAQ \\MP.IOCBPAGE 3 "No place for IOCB page at startup") (RPAQ \\MP.MOB 4 "Map out of bounds") (RPAQQ \\MP.INVALIDADDR 5) (RPAQQ \\MP.INVALIDVP 6) (RPAQ \\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain") (RPAQ \\MP.SELECTLOOP 8 "Loop in \\SELECTREALPAGE") (RPAQ \\MP.NEWPAGE 9 "Attempt to allocate already existing page") (RPAQ \\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page") (RPAQ \\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another") (RPAQ \\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box") (RPAQ \\MP.RESIDENT 13 "Fault on resident page") (RPAQ \\MP.STACKFAULT 14 "Fault on stack") (RPAQ \\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") (RPAQ \\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (RPAQ \\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code") (RPAQQ \\MP.STACKFULL 19) (RPAQQ \\MP.MDSFULL 20) (RPAQQ \\MP.UNKNOWN.UFN 21) (RPAQQ \\MP.ATOMSFULL 22) (RPAQQ \\MP.PNAMESFULL 23) (RPAQQ \\MP.USECOUNTOVERFLOW 24) (RPAQQ \\MP.MDSFULLWARNING 25) (RPAQQ \\MP.BADMDSFREELIST 26) (RPAQQ \\MP.BADARRAYBLOCK 27) (RPAQQ \\MP.BADDELETEBLOCK 28) (RPAQQ \\MP.BADARRAYRECLAIM 29) (RPAQ \\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") (RPAQ \\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (RPAQQ \\MP.DELREF0 32) (RPAQQ \\MP.PROCERROR 33) (RPAQ \\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (RPAQQ \\MP.32MBINUSE 35) (RPAQ \\MP.TOPUNWOUND 36 "Unexpected (RETTO T)") (RPAQQ \\MP.STACKRELEASED 37) (RPAQQ \\MP.FLUSHLOCKED 38) (RPAQQ \\MP.MAPNOTLOCKED 39) (RPAQQ \\MP.UNLOCKINGMAP 40) (RPAQ \\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (RPAQ \\MP.BADRUNTABLE 42 "Malformed run table for vmem file") (CONSTANTS (\\MP.OBSOLETEVMEM 1) (\\MP.INVALIDVMEM 2 "Vmem inconsistent at startup") (\\MP.IOCBPAGE 3 "No place for IOCB page at startup") (\\MP.MOB 4 "Map out of bounds") (\\MP.INVALIDADDR 5) ( \\MP.INVALIDVP 6) (\\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain") (\\MP.SELECTLOOP 8 "Loop in \\SELECTREALPAGE") (\\MP.NEWPAGE 9 "Attempt to allocate already existing page") ( \\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page") (\\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another") (\\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box") (\\MP.RESIDENT 13 "Fault on resident page") (\\MP.STACKFAULT 14 "Fault on stack") (\\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") ( \\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code") (\\MP.STACKFULL 19) (\\MP.MDSFULL 20) (\\MP.UNKNOWN.UFN 21) ( \\MP.ATOMSFULL 22) (\\MP.PNAMESFULL 23) (\\MP.USECOUNTOVERFLOW 24) (\\MP.MDSFULLWARNING 25) ( \\MP.BADMDSFREELIST 26) (\\MP.BADARRAYBLOCK 27) (\\MP.BADDELETEBLOCK 28) (\\MP.BADARRAYRECLAIM 29) ( \\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") ( \\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\\MP.DELREF0 32) (\\MP.PROCERROR 33) (\\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\\MP.32MBINUSE 35) (\\MP.TOPUNWOUND 36 "Unexpected (RETTO T)") (\\MP.STACKRELEASED 37) (\\MP.FLUSHLOCKED 38) (\\MP.MAPNOTLOCKED 39) ( \\MP.UNLOCKINGMAP 40) (\\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\\MP.BADRUNTABLE 42 "Malformed run table for vmem file")) (GLOBALVARS \\ARRAYSPACE \\ARRAYSPACE2 \\ATOMSPACE |\\AtomHashTable| \\SMALLPOSPSPACE \\SMALLNEGSPACE \\PNPSPACE \\OLDATOMSPACE \\DEFSPACE \\VALSPACE \\PLISTSPACE \\PAGEMAP |\\PageMapTBL| |\\InterfacePage| \\IOPAGE |\\DoveIORegion| \\IOCBPAGE \\FPTOVP |\\MDSTypeTable| \\MISCSTATS |\\UFNTable| |\\DTDSpaceBase| \\LISTPDTD \\LOCKEDPAGETABLE \\STACKSPACE \\HTMAIN \\HTOVERFLOW \\HTBIGCOUNT \\HTCOLL \\DISPLAYREGION) (BLOCKRECORD MISCSTATS ((STARTTIME FIXP) (TOTALTIME FIXP) (SWAPWAITTIME FIXP) (PAGEFAULTS FIXP) ( SWAPWRITES FIXP) (DISKIOTIME FIXP) (DISKOPS FIXP) (KEYBOARDWAITTIME FIXP) (GCTIME FIXP) (NETIOTIME FIXP) (NETIOOPS FIXP) (SWAPTEMP0 FIXP) (SWAPTEMP1 FIXP) (RCLKSECOND FIXP) (SECONDSCLOCK FIXP) ( MILLISECONDSCLOCK FIXP) (BASECLOCK FIXP) (RCLKTEMP0 FIXP) (SECONDSTMP FIXP) (MILLISECONDSTMP FIXP) ( BASETMP FIXP) (EXCESSTIMETMP FIXP) (CLOCKTEMP0 FIXP) (DISKTEMP0 FIXP) (DISKTEMP1 FIXP) (TELERAIDTEMP1 FIXP) (TELERAIDTEMP2 FIXP) (TELERAIDTEMP3 FIXP) (LASTUSERACTION FIXP) (DLMOUSETIMER FIXP) (DLMOUSETEMP FIXP)) (CREATE (\\ALLOCBLOCK 31))) (BLOCKRECORD IFPAGE ((|CurrentFXP| WORD) (* \; "First 7 items are FX values for user and 6 system contexts.") (|ResetFXP| WORD) (|SubovFXP| WORD) ( |KbdFXP| WORD) (|HardReturnFXP| WORD) (GCFXP WORD) (FAULTFXP WORD) (|EndOfStack| WORD) (* \; "Stack high-water mark: address of guard block at current end of stack") (|LVersion| WORD) (* \; "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp") ( |MinRVersion| WORD) (|MinBVersion| WORD) (|RVersion| WORD) (* \; "Bcpl fills in the actual microcode, Bcpl versions.") (|BVersion| WORD) (|MachineType| WORD) ( |MiscFXP| WORD) (* \; "FX for MISC context") (|Key| WORD) (* \; "= IFPValidKey if vmem consistent.") ( |SerialNumber| WORD) (* \; "Pup host number (Dorado/Dolphin)") (|EmulatorSpace| WORD) (* \; "Hiloc of bcpl space (always zero now)") (|ScreenWidth| WORD) (|NxtPMAddr| WORD) (* \; "Next page to be allocated in secondary page map table") (NIL WORD) (* \; "WAS NActivePages, Length of vmem in use") (NIL WORD) (* \; "WAS NDirtyPages, not used, but maintained as = NActivePages") (|filePnPMP0| WORD) (* \; "Sysout page number of first page of secondary page map table (\\PAGEMAP), which is where the secondary map pages themselves live" ) (|filePnPMT0| WORD) (* \; "Sysout page number of first page of primary page map table") (TELERAIDFXP WORD) (* \; "FX for TeleRaid server context") (NATIVE-START-MEM-PAGE WORD) (* \; "Unix page where native code starts") (NATIVE-LENGTH-PAGE WORD) (* \; "Unix page length of native code") (NATIVE-PAGE-OFFSET WORD) (* \; "Lisp Disk Page offset of native code") (|UserNameAddr| WORD) (* \; "Addresses in bcpl space (seg 0) of global user name and password") (|UserPswdAddr| WORD) (|StackBase| WORD) (* \; "Stack address where user stack starts") (FAULTHI WORD) (* \; "Microcode for page fault stores fault address here, then does context switch to FAULTFXP") (FAULTLO WORD) (DEVCONFIG WORD) (* \; "IT'S FOR KB,DISP TYPE") (* \; "Formerly REALPAGETABLE, back when it was always in Bcpl space.") (RPTSIZE WORD) (* \; "Number of entries in Real Page Table") (RPOFFSET WORD) (* \; "RP-RPOFFSET => index in table") ( MAXETHERBYTES WORD) (* \; "Number of bytes available in a pbi, not counting encapsulation (Dorado)") ( EMBUFVP WORD) (* \; "VP of a one-page emulator buffer") (|NSHost0| WORD) (* \; "Machine's 48-bit NS host number. Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in." ) (|NSHost1| WORD) (|NSHost2| WORD) (|MDSZone| WORD) (* \; "Obsolete -- was used by Dolphin 10MB network code.") (|MDSZoneLength| WORD) (EMUBUFFERS WORD) (* \; "Buffer space in segment 0 for swapping/disk activity") (EMUBUFLENGTH WORD) (* \; "Number of words of said space") (* |;;| "The following 2 are available if NEW_STOARGE is specified in C") (|ProcessSize| WORD) (* \; "Process size for which can be use as LISP space") (|StorageFullState| WORD) (* \; "Save last storage state") (ISFMAP WORD) (* |;;| "The following 4 are for \\MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!" ) (MISCSTACKFN FULLXPOINTER) (MISCSTACKARG1 FULLXPOINTER) (MISCSTACKARG2 FULLXPOINTER) ( MISCSTACKRESULT FULLXPOINTER) (|NRealPages| WORD) (* \; "Number pages of real memory") ( |LastLockedFilePage| WORD) (* \; "Last page of vmem that is locked--booting has to load at least that far.") (|LastDominoFilePage| WORD ) (* \; "Last sysout page reserved for Dandelion microcode") (|FPTOVPStart| WORD) (* \; "Sysout page where FPTOVP starts") (FAKEMOUSEBITS WORD) (* \; "Used to implement fake middle button on 2-button Dandelion.") (|DL24BitAddressable| WORD) (* \; "non-zero if DLion capable of addressing 32MB virtual memory") (REALPAGETABLEPTR FULLXPOINTER) (* \; "Address of real page table, set up by Bcpl (but not chained together)") (SYSDISK WORD) (* \; "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.") (|FullSpaceUsed| WORD) ( * \; "Non-zero if vmem beyond initial 8MB has been allocated.") (FAKEKBDAD4 WORD) (FAKEKBDAD5 WORD) (* |;;| "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with." ) (|XVmemFmapBase| WORD) (* \; "Bcpl stores isf map pointer to each partition here. First is redundant with ISFMAP field above.") ( NIL WORD) (NIL WORD) (|XVmemFmapHighBase| WORD) (* \; "Bcpl stores the highest vm page contained in this or earlier partition.") (NIL WORD) (NIL WORD) ( |XVmemDiskBase| FULLXPOINTER) (* \; "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).") (NIL FULLXPOINTER) (NIL FULLXPOINTER) (|DLLastVmemPage| FIXP) (* \; "DLion booting microcode puts length of vmem file here.") (|NActivePages| FIXP) (* \; "Length of vmem in use") (|NDirtyPages| FIXP) (* \; "not used, but maintained as = NActivePages")) ( CREATE (\\ALLOCBLOCK 43))) (BLOCKRECORD IOPAGE ((NIL 18 WORD) (DLMAINTPANEL WORD) (DLFLOPPYCMD WORD) (DLTTYPORTCMD WORD) ( DLPROCESSORCMD WORD) (NEWMOUSESTATE WORD) (DLBEEPCMD WORD) (DLRS232CMISCCOMMAND WORD) (DLRS232CPUTFLAG WORD) (DLRS232CGETFLAG WORD) (NIL 6 WORD) (DLFLOPPY WORD) (DLTTYOUT WORD) (NIL 1 WORD) (DLTTYIN WORD) (NIL 1 WORD) (DLPROCESSOR2 WORD) (DLPROCESSOR1 WORD) (DLPROCESSOR0 WORD) (NEWMOUSEX WORD) (NEWMOUSEY WORD) (DLBEEPFREQ WORD) (DLRS232CPARAMETERCSBLO WORD) (DLRS232CPARAMETERCSBHI WORD) ( DLRS232CSETRS366STATUS 3 WORD) (DLRS232CPUTCSBLO WORD) (DLRS232CPUTCSBHI WORD) (DLRS232CGETCSBLO WORD) (DLRS232CGETCSBHI WORD) (DLRS232CDEVICESTATUS WORD) (DLRS232CPARAMETEROUTCOME WORD) (DLTODVALID WORD) (DLTODLO WORD) (DLTODHI WORD) (DLTODLO2 WORD) (DLMOUSEX WORD) (DLMOUSEY WORD) (DLUTILIN WORD) ( DLKBDAD0 WORD) (DLKBDAD1 WORD) (DLKBDAD2 WORD) (DLKBDAD3 WORD) (DLKBDAD4 WORD) (DLKBDAD5 WORD) ( DLLSEPIMAGECSB 32 WORD) (DLIOPHARDWARECONFIG WORD) (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) ( DLRS232CPARAMETERCSBHI.11 WORD) (DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) ( DLETHERNET 12 WORD) (NIL 31 WORD) (DLDISPINTERRUPT WORD) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) ( DLCURSORX WORD) (DLCURSORY WORD) (DLCURSORBITMAP 16 WORD)) (ACCESSFNS IOPAGE ((DLCURSORBITMAPPTR ( \\ADDBASE DATUM 240)) (DLCURSORYPTR (\\ADDBASE DATUM 239)) (DLCURSORXPTR (\\ADDBASE DATUM 238)) ( DLDISPINTERRUPTPTR (\\ADDBASE DATUM 235)) (DLETHERNETPTR (\\ADDBASE DATUM 192)) (DLKBDAD5PTR ( \\ADDBASE DATUM 67)) (DLKBDAD4PTR (\\ADDBASE DATUM 66)) (DLKBDAD3PTR (\\ADDBASE DATUM 65)) ( DLKBDAD2PTR (\\ADDBASE DATUM 64)) (DLKBDAD1PTR (\\ADDBASE DATUM 63)) (DLKBDAD0PTR (\\ADDBASE DATUM 62) ) (DLUTILINPTR (\\ADDBASE DATUM 61)) (DLMOUSEYPTR (\\ADDBASE DATUM 60)) (DLMOUSEXPTR (\\ADDBASE DATUM 59)) (DLTODLOPTR (\\ADDBASE DATUM 56)) (DLMAINTPANELPTR (\\ADDBASE DATUM 18)))) (CREATE (\\ALLOCBLOCK 128))) (PUTPROPS EMADDRESS MACRO (ARGS ((LAMBDA (ADDR) (COND ((EQ |\\D1BCPLspace| |\\D0BCPLspace|) (LIST ( BIG-VMEM-CODE (LIST (QUOTE OPCODES) (QUOTE GCONST) 0 0 (LRSH ADDR 8) (LOGAND ADDR 255)) (LIST (QUOTE OPCODES) (QUOTE GCONST) 0 (LRSH ADDR 8) (LOGAND ADDR 255))))) (T (BQUOTE (\\VAG2 (|fetch| |EmulatorSpace| |of| |\\InterfacePage|) \, ADDR))))) (EVAL (CAR ARGS))))) (PUTPROPS EMGETBASE MACRO ((OFFSET) (\\GETBASE (EMADDRESS OFFSET) 0))) (PUTPROPS EMPUTBASE MACRO ((OFFSET VAL) (\\PUTBASE (EMADDRESS OFFSET) 0 VAL))) (PUTPROPS EMULATORSEGMENT MACRO (NIL (|fetch| |EmulatorSpace| |of| |\\InterfacePage|))) (PUTPROPS EMPOINTER MACRO (X (COND ((NEQ |\\D1BCPLspace| |\\D0BCPLspace|) (LIST (QUOTE \\VAG2) (QUOTE (|fetch| (IFPAGE |EmulatorSpace|) |of| |\\InterfacePage|)) (CAR X))) ((ZEROP (CAR X)) NIL) (T (LIST ( QUOTE \\VAG2) |\\D0BCPLspace| (CAR X)))))) (PUTPROPS EMADDRESSP MACRO (X (LIST (QUOTE EQ) (LIST (QUOTE \\HILOC) (CAR X)) (COND ((EQ |\\D1BCPLspace| |\\D0BCPLspace|) |\\D0BCPLspace|) (T (QUOTE (|fetch| (IFPAGE |EmulatorSpace|) |of| |\\InterfacePage|))))))) (PUTPROP (QUOTE LLPARAMS) (QUOTE IMPORTDATE) (IDATE "31-Jan-1998 09:16:51")) (DATATYPE COMPILED-CLOSURE (FNHEADER ENVIRONMENT)) (RPAQQ \\COMPILED-CLOSURE 13) (CONSTANTS \\COMPILED-CLOSURE) (PUTPROPS \\EXTENDED.EQP MACRO (OPENLAMBDA (X Y) (COND ((EQ (NTYPX X) (NTYPX Y)) (SELECTC (NTYPX X) ( \\STACKP (EQ (|fetch| (STACKP EDFXP) |of| X) (|fetch| (STACKP EDFXP) |of| Y))) (\\COMPILED-CLOSURE ( EQDEFP X Y)) NIL))))) (PUTPROPS DPUTCODE MACRO ((FN CA SIZE) (SELECTQ (SYSTEMTYPE) (D (DEFC FN CA)) (/PUTPROP FN (QUOTE DCODE) CA)))) (PUTPROPS MCODEP MACRO ((X) (OR (ARRAYP X) (AND (LITATOM X) (ARRAYP (SELECTQ (SYSTEMTYPE) (D (GETD X)) (GETPROP X (QUOTE DCODE)))))))) (PUTPROPS CODELT MACRO ((CA N) (\\BYTELT CA N))) (PUTPROPS CODELT2 MACRO (OPENLAMBDA (DEF LC) (LOGOR (LLSH (CODELT DEF LC) BITSPERBYTE) (CODELT DEF ( ADD1 LC))))) (PUTPROPS CODESETA2 MACRO (OPENLAMBDA (DEF LC VALUE) (CODESETA DEF LC (LRSH VALUE BITSPERBYTE)) ( CODESETA DEF (ADD1 LC) (IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE)))))) (PUTPROPS CODESETA MACRO ((CA N NV) (\\BYTESETA CA N NV))) (PUTPROPS BYTESPERNAMEENTRY MACRO (NIL (UNFOLD (CONSTANT (WORDSPERNAMEENTRY)) BYTESPERWORD))) (PUTPROPS BYTESPERNTOFFSETENTRY MACRO (NIL (UNFOLD (WORDSPERNAMEENTRY) BYTESPERWORD))) (PUTPROPS GETNAMEENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (* |;;| "Must ALWAYS be called with DEF really being either a FNHEADER or a nametable pseudo-fnheader. Never use addbase to offset from it. This is because CODEBASEELT checks the BYTESWAPPED flag in the fnheader...." ) (FOR I FROM 0 TO (CONSTANT (SUB1 (BYTESPERNAMEENTRY))) DO (SETQ NUMBER (LOGOR (LLSH NUMBER BITSPERBYTE) (CODEBASELT DEF (IPLUS LC I))))) NUMBER))) (PUTPROPS GETNTFLAGS MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF LC))) (PUTPROPS GETNTOFFSET MACRO (OPENLAMBDA (DEF LC) (NTSLOT-OFFSET (GETNTOFFSETENTRY DEF LC)))) (PUTPROPS GETNTOFFSETENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (|for| I |from| 0 |to| ( CONSTANT (SUB1 (BYTESPERNTOFFSETENTRY))) |do| (SETQ NUMBER (LOGOR (LLSH NUMBER BITSPERBYTE) ( CODEBASELT DEF (IPLUS LC I))))) NUMBER))) (PUTPROPS GETNTTAG MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF (ADD1 LC)))) (PUTPROPS SETNAMEENTRY MACRO (OPENLAMBDA (DEF LC VALUE) (FOR I FROM (CONSTANT (SUB1 (BYTESPERNAMEENTRY ))) TO 0 BY -1 DO (CODEBASESETA DEF (IPLUS LC I) (LOGAND VALUE (CONSTANT (SUB1 (LLSH 1 BITSPERBYTE)))) ) (SETQ VALUE (LRSH VALUE BITSPERBYTE))))) (PUTPROPS WORDSPERNTOFFSETENTRY MACRO (NIL (WORDSPERNAMEENTRY))) (PUTPROPS NTSLOT-OFFSET MACRO ((X) (LOGAND 255 X))) (DEFMACRO NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM) (* |;;| "Use one form or another, depending on whether we're compiling for new 3-byte atoms or old 2-byte atom numbers." ) (COND ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*) (* \; "NEW ATOMS") (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, OLD-SYMBOL-FORM))))) (DEFOPTIMIZER BIG-VMEM-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* |;;| "Allow for differences between 4-byte pointers and 3-byte pointers..") (COND ((FMEMB :4-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, OLD-SYMBOL-FORM))))) (DEFOPTIMIZER SETSTKNAMEENTRY (CODEARRAY OFFSET VAL &ENVIRONMENT ENV) (* |;;| "Set the name entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LET ((BASE (|fetch| (ARRAYP BASE) |of| (\\\, CODEARRAY))) (VALUE (\\\, VAL))) (COND (( FIXP VALUE) (* \; "A 20-byte atom #. Make it an atom.") (\\PUTBASEPTR BASE (\\\, OFFSET) (\\VAG2 |\\AtomHI| VALUE))) (T (* \; "A 3-byte atom. Just use it.") (\\PUTBASEPTR BASE (\\\, OFFSET) VALUE))) ))) (T (BQUOTE (LET ((BASE (|fetch| (ARRAYP BASE) |of| (\\\, CODEARRAY)))) (\\PUTBASE BASE (\\\, OFFSET) (\\\, VAL))))))) (DEFOPTIMIZER SETSTKNTOFFSETENTRY (BASE OFFSET VAL &ENVIRONMENT ENV) (* |;;| "Set the offset entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\PUTBASEFIXP (\\\, BASE) (\\\, OFFSET) (\\\, VAL)))) (T (BQUOTE (\\PUTBASE (\\\, BASE ) (\\\, OFFSET) (\\\, VAL)))))) (DEFOPTIMIZER GETSTKNAMEENTRY (BASE OFFSET &ENVIRONMENT ENV) (* |;;| "Get a name entry out of a name table. BASE is the start of the name table; OFFSET is in words, not bytes or name entries." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\GETBASEPTR (\\\, BASE) ( \\\, OFFSET)))) (T (BQUOTE (\\GETBASE (\\\, BASE) (\\\, OFFSET)))))) (DEFOPTIMIZER GETSTKNTOFFSETENTRY (BASE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\GETBASEFIXP (\\\, BASE) (\\\, OFFSET)))) (T (BQUOTE (\\GETBASE (\\\, BASE) (\\\, OFFSET)))))) (DEFOPTIMIZER WORDSPERNAMEENTRY (&ENVIRONMENT ENV) (* |;;| "Number of words in a name-table \"Name\" entry--the space for the symbol. 1 for old symbol systems, 2 for 3-byte-atom systesm." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN 2))) ((AND CROSSCOMPILING (FMEMB :3-BYTE-INIT (COMPILER::ENV-TARGET-ARCHITECTURE ENV))) (BQUOTE (PROGN 2))) (T ( BQUOTE (PROGN 1))))) (DEFOPTIMIZER SETSTKNTOFFSET (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* |;;| "Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\\FIXCODENUM (\\\, BASE) (IDIFFERENCE (\\\, OFFSET) BYTESPERWORD) (\\\, TYPE)) (\\FIXCODENUM (\\\, BASE) (\\\, OFFSET) ( \\\, VAL))))) (T (BQUOTE (\\FIXCODENUM (\\\, BASE) (\\\, OFFSET) (IPLUS (\\\, TYPE) (\\\, VAL))))))) (DEFOPTIMIZER SETSTKNAME-RAW (BASE OFFSET VAL &ENVIRONMENT ENV) (* |;;| "Set the name entry for a name-table entry. This version works with raw storage, as opposed to SETSTKNAMEENTRY, which works on an ARRAYP." ) (* |;;| "If this optimizer changes, change SETSTKNAMEENTRY as well.") (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LET ((VALUE (\\\, VAL))) (COND ((FIXP VALUE) (* \; "A 20-byte atom #. Make it an atom.") (\\PUTBASEPTR (\\\, BASE) (\\\, OFFSET) (\\VAG2 |\\AtomHI| VALUE))) (T (* \; "A 3-byte atom. Just use it.") (\\PUTBASEPTR (\\\, BASE) (\\\, OFFSET) VALUE)))))) (T (BQUOTE (\\PUTBASE (\\\, BASE) (\\\, OFFSET) (\\\, VAL)))))) (DEFOPTIMIZER SETSTKNTOFFSET-RAW (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* |;;| "Set the offset entry for a name-table entry. This version works on raw storage, vs SETSTKNAMEOFFSETENTRY, which is supposed to work on codearrays. Any changes here should be made there, as well. TYPE must already be shifted left by 14 bits." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\\PUTBASE (\\\, BASE) (\\\, OFFSET) (\\\, TYPE)) (\\PUTBASE (\\\, BASE) (IPLUS (\\\, OFFSET) 1) (\\\, VAL))))) (T (BQUOTE ( \\PUTBASE (\\\, BASE) (\\\, OFFSET) (IPLUS (\\\, TYPE) (\\\, VAL))))))) (DEFOPTIMIZER NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* |;;| "Allow for differences between 3-byte atoms and 2-byte atoms.") (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, OLD-SYMBOL-FORM))))) (DEFOPTIMIZER MAKE-NTENTRY (TYPE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (IPLUS (CONSTANT (LLSH (\\\, TYPE) 16)) (\\\, OFFSET)) )) (T (BQUOTE (IPLUS (CONSTANT (\\\, TYPE)) (\\\, OFFSET)))))) (DEFOPTIMIZER NULL-NTENTRY (VALUE &ENVIRONMENT ENV) (* |;;| "Predicate: Is VALUE a null entry in a name table? I.e., does it result from fetching the entry at the end that`s all zeros? For 2-byte atoms, that's the same as being zero. For 3-byte atoms, it's the same as being NIL." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (NULL (\\\, VALUE)))) (T ( BQUOTE (EQ (\\\, VALUE) 0))))) (DEFOPTIMIZER NTSLOT-VARTYPE (X &ENVIRONMENT ENV) (* |;;| "Given the contents of a name-table Offset entry, return the variable-type bits at the top of the entry. THE RESULT IS RETURNED SHEFTED LEFT 14 BITS, THE USUAL REPRESENTATION." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LOGAND 49153 (LRSH (\\\, X) 16)))) (T (BQUOTE (LOGAND (\\\, X) 49152))))) (ACCESSFNS CODEARRAY ((STKMIN (CODELT2 DATUM 0) (CODESETA2 DATUM 0 NEWVALUE)) (NA (SIGNED (CODELT2 DATUM 2) BITSPERWORD) (CODESETA2 DATUM 2 (UNSIGNED NEWVALUE BITSPERWORD))) (PV (SIGNED (CODELT2 DATUM 4) BITSPERWORD) (CODESETA2 DATUM 4 (UNSIGNED NEWVALUE BITSPERWORD))) (STARTPC (CODELT2 DATUM 6) ( CODESETA2 DATUM 6 NEWVALUE)) (ARGTYPE (LOGAND (LRSH (CODELT DATUM 8) 4) 3) (CODESETA DATUM 8 (LOGOR ( LOGAND (CODELT DATUM 8) 207) (LLSH (LOGAND NEWVALUE 3) 4)))) (FRAMENAME (\\VAG2 (LOGAND (CODELT2 DATUM 8) 4095) (CODELT2 DATUM 10)) (\\FIXCODEPTR DATUM 11 (EVQ NEWVALUE))) (NTSIZE (CODELT2 DATUM 12) ( CODESETA2 DATUM 12 NEWVALUE)) (NLOCALS (CODELT DATUM 14) (CODESETA DATUM 14 NEWVALUE)) (FVAROFFSET ( CODELT DATUM 15) (CODESETA DATUM 15 NEWVALUE))) (ACCESSFNS CODEARRAY ((LSTARP (ILESSP (|fetch| ( CODEARRAY NA) |of| DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (ALIGNED (IPLUS (|fetch| (CODEARRAY NTSIZE) |of| DATUM) (|fetch| (CODEARRAY OVERHEADWORDS) |of| T))) (FIXED NIL (|replace| (CODEARRAY STKMIN) |of| DATUM |with| (\\STKMIN DATUM))) (FRAMENAME# (PROGN 8))))) (RECORD OPCODE (OP# OPCODENAME OPNARGS OPPRINT LEVADJ UFNFN UNIMPL)) (GLOBALVARS \\OPCODES) (RPAQQ PVARCODE 32768) (RPAQQ FVARCODE 49152) (RPAQQ IVARCODE 0) (RPAQQ VARCODEMASK 49152) (CONSTANTS PVARCODE FVARCODE IVARCODE VARCODEMASK) (RPAQQ \\NT.IVARCODE 0) (RPAQQ \\NT.PVARCODE 2) (RPAQQ \\NT.FVARCODE 3) (CONSTANTS \\NT.IVARCODE \\NT.PVARCODE \\NT.FVARCODE) (PUTPROP (QUOTE LLCODE) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 10:45:33")) (RPAQQ \\ERRORMESSAGELIST ("SYSTEM ERROR" " " "STACK OVERFLOW" "ILLEGAL RETURN" "ARG NOT LIST" "HARD DISK ERROR" "ATTEMPT TO SET NIL OR T" "ATTEMPT TO RPLAC NIL" "UNDEFINED OR ILLEGAL GO" "FILE WON'T OPEN" "NON-NUMERIC ARG" "ATOM TOO LONG" "ATOM HASH TABLE FULL" "FILE NOT OPEN" "ARG NOT LITATOM" "! too many files open" "END OF FILE" "ERROR" "BREAK" "ILLEGAL STACK ARG" "FAULT IN EVAL" "ARRAYS FULL" "FILE SYSTEM RESOURCES EXCEEDED" "FILE NOT FOUND" "BAD SYSOUT FILE" "UNUSUAL CDR ARG LIST" "HASH TABLE FULL" "ILLEGAL ARG" "ARG NOT ARRAY" "ILLEGAL OR IMPOSSIBLE BLOCK" "STACK PTR HAS BEEN RELEASED" "STORAGE FULL" "ATTEMPT TO USE ITEM OF INCORRECT TYPE" "ILLEGAL DATA TYPE NUMBER" "DATA TYPES FULL" "ATTEMPT TO BIND NIL OR T" "! too many user interrupt characters" "! read-macro context error" "ILLEGAL READTABLE" "ILLEGAL TERMINAL TABLE" "! swapblock too big for buffer" "PROTECTION VIOLATION" "BAD FILE NAME" "USER BREAK" "UNBOUND ATOM" "UNDEFINED CAR OF FORM" "UNDEFINED FUNCTION" "CONTROL-E" "FLOATING UNDERFLOW" "FLOATING OVERFLOW" "OVERFLOW" "ARG NOT HARRAY" "TOO MANY ARGUMENTS")) (DEFOPTIMIZER LISPERROR (MESSAGE ARG) (BQUOTE (\\LISPERROR (\\\, ARG) (\\\, (CL:IF (CL:STRINGP MESSAGE ) (FOR X IN \\ERRORMESSAGELIST AS I FROM 0 WHEN (CL:EQUAL X MESSAGE) DO (RETURN I) FINALLY (RETURN ( HELP "Unknown error message" (LIST MESSAGE ARG)))) MESSAGE))))) (PUTPROP (QUOTE AERROR) (QUOTE IMPORTDATE) (IDATE "16-May-1990 11:58:35")) (RECORD BASEBYTESTREAM STREAM (SUBRECORD STREAM) (ACCESSFNS ((BIASOFFST (|fetch| (STREAM FW6) |of| DATUM) (|replace| (STREAM FW6) |of| DATUM |with| NEWVALUE)) (BBSNCHARS (|fetch| (STREAM FW7) |of| DATUM) (|replace| (STREAM FW7) |of| DATUM |with| NEWVALUE)) (WRITEXTENSIONFN (|fetch| (STREAM F1) |of| DATUM) (|replace| (STREAM F1) |of| DATUM |with| NEWVALUE))))) (PUTPROPS \\INSTREAMARG MACRO ((STRM NOERRORFLG) (\\GETSTREAM STRM (QUOTE INPUT) NOERRORFLG))) (PUTPROPS \\OUTSTREAMARG MACRO ((STRM NOERRORFLG) (\\GETSTREAM STRM (QUOTE OUTPUT) NOERRORFLG))) (PUTPROPS \\STREAMARG MACRO (OPENLAMBDA (STRM NOERRORFLG) (COND (NOERRORFLG (\\GETSTREAM STRM NIL T)) (T (\\DTEST STRM (QUOTE STREAM)))))) (PUTPROP (QUOTE AOFD) (QUOTE IMPORTDATE) (IDATE "13-Sep-1990 16:39:58")) (PUTPROPS .SPACECHECK. MACRO ((STRM N) (AND \\THISFILELINELENGTH (IGREATERP (IPLUS N (|fetch| CHARPOSITION |of| STRM)) \\THISFILELINELENGTH) (FRESHLINE STRM)))) (PUTPROPS \\CHECKRADIX MACRO (LAMBDA (R) (COND ((OR (NOT (SMALLP R)) (ILESSP R 1) (IGREATERP R 36)) ( \\INVALID.RADIX R)) (T R)))) (PUTPROPS \\XCCSFILEOUTCHARFN MACRO ((OUTSTREAM CHARCODE) (* |;;;| "Encoder for XCCS format. Default decoder.") (COND ((EQ CHARCODE (CHARCODE EOL)) (COND ((NOT ( \\RUNCODED OUTSTREAM)) (* \; "Charset is a constant 0") (\\BOUT OUTSTREAM (\\CHARSET (CHARCODE EOL)))) ((EQ (\\CHARSET (CHARCODE EOL)) (|ffetch| (STREAM CHARSET) |of| OUTSTREAM))) (T (\\BOUT OUTSTREAM NSCHARSETSHIFT) (\\BOUT OUTSTREAM (|freplace| (STREAM CHARSET) |of| OUTSTREAM |with| (\\CHARSET ( CHARCODE EOL)))))) (\\BOUT OUTSTREAM (SELECTC (|ffetch| EOLCONVENTION |of| OUTSTREAM) (CR.EOLC ( CHARCODE CR)) (LF.EOLC (CHARCODE LF)) (CRLF.EOLC (\\BOUT OUTSTREAM (CHARCODE CR)) (* |;;| "Don't put out high-order byte preceding LF. The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes" ) (CHARCODE LF)) (SHOULDNT))) (|freplace| CHARPOSITION |of| OUTSTREAM |with| 0)) (T (COND ((NOT ( \\RUNCODED OUTSTREAM)) (\\BOUT OUTSTREAM (\\CHARSET CHARCODE)) (\\BOUT OUTSTREAM (\\CHAR8CODE CHARCODE ))) ((EQ (\\CHARSET CHARCODE) (|ffetch| (STREAM CHARSET) |of| OUTSTREAM)) (\\BOUT OUTSTREAM ( \\CHAR8CODE CHARCODE))) (T (\\BOUT OUTSTREAM NSCHARSETSHIFT) (\\BOUT OUTSTREAM (|freplace| (STREAM CHARSET) |of| OUTSTREAM |with| (\\CHARSET CHARCODE))) (\\BOUT OUTSTREAM (\\CHAR8CODE CHARCODE)))) ( |freplace| CHARPOSITION |of| OUTSTREAM |with| (PROGN (* \; "Ugh. Don't overflow") (IPLUS16 (|ffetch| CHARPOSITION |of| OUTSTREAM) 1))))))) (PUTPROP (QUOTE APRINT) (QUOTE IMPORTDATE) (IDATE "17-Jan-2020 05:51:20")) (GLOBALVARS \\BCPLDISPLAY) (ACCESSFNS LINEBUFFER ((LPARCOUNT (|fetch| FW6 |of| DATUM) (|replace| FW6 |of| DATUM |with| NEWVALUE)) (LBRKCOUNT (|fetch| FW7 |of| DATUM) (|replace| FW7 |of| DATUM |with| NEWVALUE)) (LINEBUFSTATE ( |fetch| F5 |of| DATUM) (|replace| F5 |of| DATUM |with| NEWVALUE)) (* \; "F4 is free. EJS, 7/8/85") ( KEYBOARDSTREAM (|fetch| F2 |of| DATUM) (|replace| F2 |of| DATUM |with| NEWVALUE)) (PEEKEDCHAR (|fetch| F3 |of| DATUM) (|replace| F3 |of| DATUM |with| NEWVALUE)) (* \; "Character read by PEEKC") (LBFLAGS ( |fetch| FW9 |of| DATUM) (|replace| FW9 |of| DATUM |with| NEWVALUE)) (* |;;| "True if peeked char was echoed when peeked. Could use this to determine whether to echo later or not, but that would be incompatible with Interlisp-10, so this field not used" )) (ACCESSFNS LINEBUFFER ((LBFLAGBASE (LOCF (|fetch| LBFLAGS |of| DATUM)))) (BLOCKRECORD LBFLAGBASE (( PEEKEDECHOFLG FLAG) (INSTRINGP FLAG))))) (RPAQQ LINEBUFFERSTATES (FILLING.LBS READING.LBS RETYPING.LBS)) (RPAQQ FILLING.LBS 0) (RPAQQ READING.LBS 1) (RPAQQ RETYPING.LBS 2) (CONSTANTS FILLING.LBS READING.LBS RETYPING.LBS) (PUTPROPS \\INTERMP MACRO ((OFD) (EQ OFD \\LINEBUF.OFD))) (PUTPROPS \\OUTTERMP MACRO ((OFD) (EQ OFD \\TERM.OFD))) (GLOBALVARS \\DEFAULTLINEBUF) (PUTPROP (QUOTE ATERM) (QUOTE IMPORTDATE) (IDATE "16-May-1990 12:08:04")) (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))) (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 \\ADDBASE2 MACRO (OPENLAMBDA (BASE N) (\\ADDBASE (\\ADDBASE BASE N) N))) (PUTPROPS \\ADDBASE4 MACRO (OPENLAMBDA (BASE N) (\\ADDBASE2 (\\ADDBASE2 BASE N) N))) (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 \\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)))) (RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (UNBOXEDBLOCK.GCT 0))) (RPAQQ CODEBLOCK.GCT 2) (RPAQQ PTRBLOCK.GCT 1) (RPAQQ UNBOXEDBLOCK.GCT 0) (CONSTANTS (CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (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 |\\ArrayBlockHeaderCells| 1) (RPAQQ |\\ArrayBlockHeaderWords| 2) (RPAQQ |\\ArrayBlockTrailerCells| 1) (RPAQQ |\\ArrayBlockTrailerWords| 2) (RPAQ |\\ArrayBlockOverheadCells| (IPLUS |\\ArrayBlockHeaderCells| |\\ArrayBlockTrailerCells|)) (RPAQ |\\ArrayBlockOverheadWords| (IPLUS |\\ArrayBlockHeaderWords| |\\ArrayBlockTrailerWords|)) (RPAQQ |\\ArrayBlockLinkingCells| 2) (RPAQ |\\MinArrayBlockSize| (IPLUS |\\ArrayBlockOverheadCells| |\\ArrayBlockLinkingCells|)) (RPAQQ |\\MaxArrayBlockSize| 65535) (RPAQ |\\MaxArrayNCells| (IDIFFERENCE |\\MaxArrayBlockSize| |\\ArrayBlockOverheadCells|)) (RPAQQ |\\MaxArrayLen| 65535) (RPAQQ \\ABPASSWORDSHIFT 3) (RPAQ |\\ArrayBlockPassword| (LRSH 43690 \\ABPASSWORDSHIFT)) (RPAQ |\\FreeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH UNBOXEDBLOCK.GCT 1))) (RPAQ |\\UsedArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) 1)) (RPAQ |\\CodeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT 1) 1)) (CONSTANTS |\\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 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))) (RPAQQ \\ST.BYTE 0) (RPAQQ \\ST.POS16 1) (RPAQQ \\ST.INT32 2) (RPAQQ \\ST.CODE 4) (RPAQQ \\ST.PTR 6) (RPAQQ \\ST.FLOAT 7) (RPAQQ \\ST.BIT 8) (RPAQQ \\ST.PTR2 11) (CONSTANTS (\\ST.BYTE 0) (\\ST.POS16 1) (\\ST.INT32 2) (\\ST.CODE 4) (\\ST.PTR 6) (\\ST.FLOAT 7) ( \\ST.BIT 8) (\\ST.PTR2 11)) (RPAQQ \\MAX.CELLSPERHUNK 64) (CONSTANTS \\MAX.CELLSPERHUNK) (RPAQQ \\IN.MAKEINIT NIL) (CONSTANTS (\\IN.MAKEINIT)) (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))) (DATATYPE ARRAYP ((* |;;| "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.")) (* |;;| "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) (* \; "Used for header and trailer"))) (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|)))) (GLOBALVARS |\\NxtArrayPage| \\FREEBLOCKBUCKETS \\HUNKING?) (PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (|fetch| DTDSIZE |of| (\\GETDTD NTYPX)) WORDSPERCELL))) (PUTPROP (QUOTE LLARRAYELT) (QUOTE IMPORTDATE) (IDATE "15-Sep-1994 11:08:59")) (DEFOPTIMIZER PUTBASEPTRX (&REST ARGS) (CONS (QUOTE (OPENLAMBDA (DATUM OFFSET NEWVALUE) ( UNINTERRUPTABLY (\\PUTBASE DATUM OFFSET (LOGOR (LOGAND 61440 (\\GETBASE DATUM OFFSET)) (LOGAND ( \\HILOC NEWVALUE) 4095))) (\\PUTBASE DATUM (ADD1 OFFSET) (\\LOLOC NEWVALUE)) NEWVALUE))) ARGS)) (RPAQQ \\SMALLP 1) (RPAQQ \\FIXP 2) (RPAQQ \\FLOATP 3) (RPAQQ \\LITATOM 4) (RPAQQ \\LISTP 5) (RPAQQ \\ARRAYP 6) (RPAQQ \\STACKP 8) (RPAQQ \\VMEMPAGEP 10) (RPAQQ \\STREAM 11) (RPAQQ \\NEW-ATOM 21) (CONSTANTS \\SMALLP \\FIXP \\FLOATP \\LITATOM \\LISTP \\ARRAYP \\STACKP \\VMEMPAGEP \\STREAM \\NEW-ATOM) (RPAQQ \\BUILT-IN-SYSTEM-TYPES ((SMALLP) (FIXP 2) (FLOATP 2) (LITATOM) (LISTP 4 (0 2)) (ARRAYP 6 (0)) (STRINGP 6 (0)) (STACKP 2 NIL \\RECLAIMSTACKP) (CHARACTER) (VMEMPAGEP 256 NIL RELEASINGVMEMPAGE) ( STREAM) (BITMAP) (COMPILED-CLOSURE 4 (0 2)) (ONED-ARRAY 8 (0)) (TWOD-ARRAY 10 (0)) (GENERAL-ARRAY 10 ( 0 8)) (BIGNUM) (RATIO) (COMPLEX) (PATHNAME) (NEW-ATOM 10 (2 4 6)) (FILLER22) (FILLER23) (FILLER24) ( FILLER25) (FILLER26) (FILLER27) (FILLER28) (FILLER29) (FILLER30))) (BLOCKRECORD DTD ((NIL BITS 2) (DTDOBSOLETE FLAG) (* \; "True for type of a redeclared datatype--not allowed to allocate more of these") (DTDFINALIZABLE FLAG) (* \; "True if finalization exists for this type") (DTDNAME POINTER) (* \; "Type name -- a symbol ") (DTDCNT0 WORD) (* \; "Incremental box count -- this plus DTDOLDCNT is the true box count") (DTDSIZE WORD) (* \; "Length of datum in words") (DTDFREE FULLXPOINTER) (* \; "Pointer to first object on free chain, or NIL. Not used for LISTP") (DTDLOCKEDP FLAG) (* \; "True if objects of this type must be locked down (not pagefault)") (DTDHUNKP FLAG) (* \; "True if this type is used as an array hunk type") (DTDGCTYPE BITS 2) (* \; "For hunk datatypes, is analogous to arrayblock's GCTYPE") (DTDDESCRS POINTER) (DTDTYPESPECS POINTER) (DTDPTRS POINTER) (* \; "List of word offsets inside datum where reference-counted pointers are stored -- used by GC") ( DTDOLDCNT FIXP) (* \; "'Box count' -- number of objects of this type ever allocated") (DTDNEXTPAGE FIXP) (* \; "Currently only for LISTP pages -- page number of next page on chain of non-full cons pages") ( DTDTYPEENTRY WORD) (* |;;| "The word stored in the type table for objects of this type. Hi bits have numberp tags, ref countable, etc." ) (DTDSUPERTYPE WORD) (* \; "Type number of immediate supertype, or zero if none")) (ACCESSFNS DTD (( DTDCNTLOC (\\ADDBASE DATUM 4)) (DTDCNT (IPLUS (|fetch| DTDOLDCNT DATUM) (|fetch| DTDCNT0 DATUM)) ( UNINTERRUPTABLY (|replace| DTDOLDCNT |of| DATUM |with| NEWVALUE) (|replace| DTDCNT0 |of| DATUM |with| 0)))))) (PUTPROPS \\GETDTD MACRO ((|typeNum|) (ADDBASE |\\DTDSpaceBase| (ITIMES |typeNum| 18)))) (DEFOPTIMIZER \\TYPEMASK.UFN (&REST X) (LET ((CE (CONSTANTEXPRESSIONP (CADR X)))) (|if| CE |then| ( BQUOTE ((OPCODES TYPEMASK.N (\\\, (CAR CE))) (\\\, (CAR X)))) |else| (QUOTE IGNOREMACRO)))) (RPAQQ \\GUARDSTORAGEFULL 128) (RPAQQ \\GUARD1STORAGEFULL 64) (CONSTANTS \\GUARDSTORAGEFULL \\GUARD1STORAGEFULL) (GLOBALVARS |\\NxtMDSPage| |\\LeastMDSPage| |\\SecondArrayPage| |\\SecondMDSPage| \\MDSFREELISTPAGE |\\MaxSysTypeNum| |\\MaxTypeNumber| \\STORAGEFULL \\INTERRUPTSTATE \\PENDINGINTERRUPT) (PUTPROP (QUOTE LLDATATYPE) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:57:50")) (ACCESSFNS POINTER ((PAGE# (IPLUS (LLSH (\\HILOC DATUM) 8) (LRSH (\\LOLOC DATUM) 8))) (WORDINPAGE ( LOGAND (\\LOLOC DATUM) 255)) (CELLINPAGE (LRSH (|fetch| WORDINPAGE |of| DATUM) 1)) (BYTEINPAGE (LLSH ( |fetch| WORDINPAGE |of| DATUM) 1)) (SEGMENT# (\\HILOC DATUM)) (WORDINSEGMENT (\\LOLOC DATUM)) ( CELLINSEGMENT (LRSH (|fetch| WORDINSEGMENT |of| DATUM) 1)) (WORD# (|fetch| WORDINPAGE |of| DATUM)) ( DBLWORD# (|fetch| CELLINPAGE |of| DATUM)) (PAGEBASE (\\VAG2 (\\HILOC DATUM) (LOGAND (\\LOLOC DATUM) 65280)))) (CREATE (\\VAG2 (LRSH PAGE# 8) (LLSH (LOGAND PAGE# 255) 8)))) (ACCESSFNS WORD ((HIBYTE (LRSH DATUM 8)) (LOBYTE (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH HIBYTE 8) LOBYTE))) (PUTPROPS PTRGTP MACRO (OPENLAMBDA (X Y) (OR (IGREATERP (\\HILOC X) (\\HILOC Y)) (AND (EQ (\\HILOC X) (\\HILOC Y)) (IGREATERP (\\LOLOC X) (\\LOLOC Y)))))) (PUTPROPS .COERCE.TO.SMALLPOSP. DMACRO (OPENLAMBDA (X) (COND ((SMALLPOSP X) X) (T (\\ILLEGAL.ARG X)))) ) (PUTPROPS .COERCE.TO.BYTE. DMACRO (OPENLAMBDA (X) (COND ((AND (SMALLPOSP X) (ILESSP X (CONSTANT (LLSH 1 BITSPERBYTE)))) X) (T (\\ILLEGAL.ARG X))))) (BLOCKRECORD LISTP ((* |;;| "Describes a CONS cell.") (CAR POINTER) (CDR POINTER)) (CREATE (CREATECELL \\LISTP)) (* |;;| "FOLLOWING ARE CDR-CODE FIELDS") (BLOCKRECORD LISTP ((CDRCODE BITS 4) (CARFIELD XPOINTER))) (* |;;| "For chaining together free cells on a page:") (BLOCKRECORD LISTP ((NEXTFREE BYTE) (NIL BITS 24))) (ACCESSFNS LISTP ((FULLCARFIELD NIL (\\PUTBASEPTR DATUM 0 NEWVALUE)))) (* |;;| "because replace of XPOINTER is slow, the CAR field is stored with PUTBASEPTR, even though that smashes the hi byte" )) (BLOCKRECORD CONSPAGE ((* |;;| "Describes a page of CONS cells, which (when free) are chained together thru the top byte.") (NIL 2 FIXP) (* \; "Empty cells, space for another 2 CONS cells if we can figure out how.") (CNT BYTE) (* \; "# of cells free on this page") (NEXTCELL BYTE) (* \; "WORD offset of next free cell (not guaranteed to be 0 if no free cells)") (NIL WORD) (* \; "Padding") (NEXTPAGE FIXP) (* \; "Next CONS page on the DTD's free list, for searching for cells."))) (RPAQQ CONSCONSTANTS (\\CDR.ONPAGE \\CDR.NIL \\CDR.INDIRECT \\CDR.MAXINDIRECT \\CONSPAGE.LAST)) (RPAQQ \\CDR.ONPAGE 8) (RPAQQ \\CDR.NIL 8) (RPAQQ \\CDR.INDIRECT 0) (RPAQQ \\CDR.MAXINDIRECT 7) (RPAQQ \\CONSPAGE.LAST 65535) (CONSTANTS \\CDR.ONPAGE \\CDR.NIL \\CDR.INDIRECT \\CDR.MAXINDIRECT \\CONSPAGE.LAST) (PUTPROPS LOCAL MACRO ((X) X)) (PUTPROPS ALLOCAL MACRO ((X) X)) (PUTPROP (QUOTE LLNEW) (QUOTE IMPORTDATE) (IDATE " 2-Feb-1995 16:21:44")) (PUTPROPS CHECK MACRO (ARGS (COND ((AND (BOUNDP (QUOTE CHECK)) CHECK) (CONS (QUOTE PROGN) (|for| I |in| ARGS |collect| (LIST (QUOTE OR) I (LIST (QUOTE RAID) (KWOTE (LIST (QUOTE |Check-failure:|) I))))) )) (T (CONS COMMENTFLG ARGS))))) (PUTPROPS |\\StatsZero| BYTEMACRO (OPENLAMBDA (N) (\\PUTBASE N 0 0) (\\PUTBASE N 1 0))) (PUTPROPS |\\StatsAdd1| DMACRO (OPENLAMBDA (A) (PROG ((LO (IPLUS16 (\\GETBASE A 1) 1))) (DECLARE ( LOCALVARS LO)) (* \; "Increment double word at A by 1") (\\PUTBASE A 1 LO) (COND ((EQ LO 0) (\\PUTBASE A 0 (ADD1 (\\GETBASE A 0)))))))) (PUTPROPS IPLUS16 MACRO ((X Y) (* \; "Kludge to do 16-bit plus") (\\LOLOC (\\ADDBASE X Y)))) (PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0)))) (PROGN (PUTPROPS SETXVAR MACRO (X (BQUOTE (SETQ.NOREF \, (CADAR X) \, (CADR X))))) (PUTPROPS SETXVAR DMACRO (X (OR (AND (EQ (CAAR X) (QUOTE QUOTE)) (LITATOM (CADAR X))) (SHOULDNT)) (GLOBALVARS \\VALSPACE ) (LIST (QUOTE SETQ.NOREF) (CADAR X) (CADR X))))) (PUTPROPS SETQ.NOREF DMACRO ((VAR VAL) (\\PUTBASEPTR (LOCF (|fetch| (LITATOM VALUE) |of| (QUOTE VAR))) 0 VAL))) (PROGN (PUTPROPS IEQ MACRO ((X Y) (IEQP X Y))) (PUTPROPS IEQ DMACRO (= . EQ))) (RPAQQ |WordsPerPage| 256) (CONSTANTS |WordsPerPage|) (ACCESSFNS LITATOM ((DEFINITIONCELL (\\DEFCELL DATUM)) (PROPCELL (\\PROPCELL DATUM)) (VCELL (\\VALCELL DATUM)) (PNAMECELL (\\PNAMECELL DATUM))) (* |;;| "VCELL can also be accessed directly from a value index via the record VALINDEX (as in \\SETGLOBALVAL.UFN) --- Similarly, PNAMEINDEX accesses PNAMECELL for use by \\MKATOM and UNCOPYATOM" ) (TYPE? (LITATOM DATUM)) (BLOCKRECORD PROPCELL ((NIL BITS 4) (* \; "former flags locations") ( PROPLIST POINTER) (NIL BITS 8) (* \; "Package byte") (NIL BITS 8) (* \; "Flags from defcell") (* |;;| "PROPCell flags:") (NIL BITS 1) (GENSYMP FLAG) (FATPNAMEP FLAG) (NIL BITS 5) (* |;;| "Filler for final cell:") (NIL BITS 8)))) (SYNONYM CL:SYMBOL (LITATOM)) (ACCESSFNS VALINDEX ((VCELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* \; "Xerox Lisp traditional symbol") (\\ADDBASE2 \\PNPSPACE (IPLUS \\NEWATOM-VALOFFSET (ITIMES 10 DATUM))) ) (T (* \; "New symbol") (* \; "'90/07/19 ON") (\\ADDBASE DATUM \\NEWATOM-VALOFFSET)))))) (BLOCKRECORD VCELL ((VALUE FULLPOINTER))) (BLOCKRECORD DEFINITIONCELL ((CCODEP FLAG) (FASTP FLAG) (ARGTYPE BITS 2) (* \; "Former flag location") (DEFPOINTER POINTER) (NIL POINTER) (* \; "Proplist cell") (NIL BITS 8) (* \; "package") (* |;;| "DEFCELL flags overflow from top 4 bits of the real cell:") (NIL BITS 4) (PSEUDOCODEP FLAG) (NIL BITS 3) (* |;;| "proplist falgs and filler:") (NIL BITS 16)) (BLOCKRECORD DEFINITIONCELL ((DEFCELLFLAGS BITS 4) (NIL POINTER) (* \; "defn ptr") (NIL BITS 4) (NIL POINTER) (* \; "filler for proplist ptr") ( NIL BITS 8) (AUXDEFCELLFLAGS BYTE) (NIL BITS 16)))) (BLOCKRECORD FNHEADER ((STKMIN WORD) (NA SIGNEDWORD) (PV SIGNEDWORD) (STARTPC WORD) (CLOSUREP FLAG) (* \; "T if this is a \"compiled closure\"") (BYTESWAPPED FLAG) (* \; "T if, on 386, we reswapped the code section of this function for faster access.") (ARGTYPE BITS 2) (* \; "0 = LAMBDA") (* \; "2 = LAMBDA nospread") (* \; "1 = NLAMBDA") (* \; "3 = NLAMBDA nospread") (* |;;| "4 NIL BITS USED TO BE HERE.") (\#FRAMENAME XPOINTER) (NTSIZE WORD) (* \; "Size of the Name Table, IN WORDS. This value is always rounded up to the next Quad-word in size, and there' guaranteed to be one entry of zeros in the length." ) (NLOCALS BYTE) (FVAROFFSET BYTE)) (ACCESSFNS FNHEADER ((LSTARP (ILESSP (|fetch| (FNHEADER NA) |of| DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (NATIVE (PROGN NIL)) (* \; "T if this is a NATIVE-code function (never true!)") (ALIGNED (IPLUS (|fetch| (FNHEADER NTSIZE) |of| DATUM) (|fetch| (FNHEADER OVERHEADWORDS) |of| T))) (FIXED NIL (|replace| (FNHEADER STKMIN) |of| DATUM |with| (\\STKMIN DATUM T))) (NPVARWORDS (UNFOLD (ADD1 (|fetch| (FNHEADER PV) |of| DATUM)) WORDSPERQUAD )) (FRAMENAME (|fetch| (FNHEADER \#FRAMENAME) |of| DATUM) (UNINTERRUPTABLY (CHECK (NEQ (\\HILOC DATUM) \\STACKHI)) (\\DELREF (|fetch| (FNHEADER \#FRAMENAME) |of| DATUM)) (\\ADDREF NEWVALUE) (|replace| ( FNHEADER \#FRAMENAME) |of| DATUM |with| NEWVALUE)))))) (BLOCKRECORD PNAMECELL ((NIL BITS 4) (PNAMEBASE XPOINTER) (NIL POINTER) (* \; "val, def, prop cells") (NIL POINTER) (NIL POINTER) (PACKAGEINDEX BYTE) (NIL BITS 24) (* \; "filler for other flags")) ( BLOCKRECORD PNAMECELL ((FULLPNAMEBASE FULLXPOINTER) (* \; "Replacing this smashes PACKAGEINDEX to 0")) ) (ACCESSFNS PNAMECELL ((PACKAGE (LET ((I (FETCH (PNAMECELL PACKAGEINDEX) OF DATUM))) (* \; "This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound." ) (COND ((EQ 0 I) NIL) (T (CL:AREF *PACKAGE-FROM-INDEX* I)))) (REPLACE (PNAMECELL PACKAGEINDEX) OF DATUM WITH (IF (NULL NEWVALUE) THEN *UNINTERNED-PACKAGE-INDEX* ELSE (CL::%PACKAGE-INDEX NEWVALUE)))))) ) (ACCESSFNS PACKAGEINDEX ((PACKAGE (IF (EQ 0 DATUM) (* \; "This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound." ) THEN NIL ELSE (CL:AREF *PACKAGE-FROM-INDEX* DATUM))))) (BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE) (* \; "Length is always here, be the pname thin or fat") ( PNAMEFATPADDINGBYTE BYTE) (* \; "This byte is zero for fat pnames so that the pname chars are word-aligned"))) (ACCESSFNS PNAMEINDEX ((PNAMECELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* \; "Xerox Lisp traditional symbol") (\\ADDBASE \\OLDATOMSPACE (IPLUS \\NEWATOM-PNAMEOFFSET (ITIMES 10 DATUM)))) (T (* \; "New symbol") (* \; "'90/07/19 ON") (\\ADDBASE DATUM \\NEWATOM-PNAMEOFFSET)))))) (BLOCKRECORD NEW-ATOM ((* |;;| "An extended symbol, for expanding atom space. Kept in its own datatype.") (PNAME XPOINTER) (* \; "PNAME, same as litatom.") (VALUE POINTER) (DEF POINTER) (PROPLIST POINTER) (* |;;| "Flags that used to be above the pointers, e.g. package, ccodep, gensymp:") (NIL BITS 32))) (PUTPROPS \\DEFCELL MACRO ((ATOM) (\\ATOMCELL ATOM \\DEF.HI))) (PUTPROPS \\VALCELL MACRO ((ATOM) (\\ATOMCELL ATOM \\VAL.HI))) (PUTPROPS \\PNAMECELL MACRO ((ATOM) (\\ATOMCELL ATOM \\PNAME.HI))) (PUTPROPS \\ATOMVALINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T ( SHOULDNT))))) (PUTPROPS \\ATOMDEFINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T ( SHOULDNT))))) (PUTPROPS \\ATOMPNAMEINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T ( SHOULDNT))))) (PUTPROPS \\ATOMPROPINDEX DMACRO ((X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") ( \\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (SHOULDNT))))) (PUTPROPS \\INDEXATOMPNAME DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol") (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) ( LOGAND X 65535))))) (T (* \; "New symbol") X)))) (PUTPROPS \\INDEXATOMVAL DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol") (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* \; "New symbol") X)))) (PUTPROPS \\INDEXATOMDEF DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol") (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* \; "New symbol") X)))) (PUTPROPS \\ATOMNUMBER DMACRO (= . \\LOLOC)) (GLOBALVARS |\\NxtPnByte| |\\CurPnPage| |\\NxtAtomPage| |\\AtomFrLst| |\\OneCharAtomBase| \\PNAMES.IN.BLOCKS? \\SCRATCHSTRING COMPILEATPUTDFLG) (RPAQQ \\PNAMELIMIT 255) (RPAQQ |\\CharsPerPnPage| 512) (CONSTANTS (\\PNAMELIMIT 255) (|\\CharsPerPnPage| 512)) (RPAQQ \\NEWATOM-PNAMEOFFSET 0) (RPAQQ \\NEWATOM-VALOFFSET 2) (RPAQQ \\NEWATOM-DEFOFFSET 4) (RPAQQ \\NEWATOM-PLISTOFFSET 6) (RPAQQ \\NEWATOM-TYPE# 21) (CONSTANTS (\\NEWATOM-PNAMEOFFSET 0) (\\NEWATOM-VALOFFSET 2) (\\NEWATOM-DEFOFFSET 4) ( \\NEWATOM-PLISTOFFSET 6) (\\NEWATOM-TYPE# 21)) (PUTPROPS \\MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) (\\BLT (\\ADDBASE DBASE DOFFSET) (\\ADDBASE SBASE SOFFSET) NWORDS))) (PUTPROP (QUOTE LLBASIC) (QUOTE IMPORTDATE) (IDATE "31-Jan-1998 09:55:50")) (ACCESSFNS STRINGP ((XREADONLY (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| DATUM) (|replace| ( ARRAY-HEADER READ-ONLY-P) |of| DATUM |with| NEWVALUE)) (XBASE ((OPENLAMBDA (STRING) (COND ((|fetch| ( ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-BASE STRING)) (T (|fetch| (ARRAY-HEADER BASE) |of| STRING)))) DATUM) ((OPENLAMBDA (STRING NV) (|replace| (ARRAY-HEADER INDIRECT-P) |of| STRING |with| NIL ) (|replace| (ARRAY-HEADER BASE) |of| STRING |with| NV) NV) DATUM NEWVALUE)) (TYP ((OPENLAMBDA (STRING ) (SELECTC (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-TYPE-NUMBER STRING)) (T ( |fetch| (ARRAY-HEADER TYPE-NUMBER) |of| STRING))) (%THIN-CHAR-TYPENUMBER \\ST.BYTE) ( %FAT-CHAR-TYPENUMBER \\ST.POS16) (SHOULDNT "Unknown type-number"))) DATUM) ((OPENLAMBDA (STRING NV) ( LET ((%NEW-TYPE-NUMBER (SELECTC NV (\\ST.BYTE %THIN-CHAR-TYPENUMBER) (\\ST.POS16 %FAT-CHAR-TYPENUMBER) (SHOULDNT "Unknown typ value")))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) ( %SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| STRING |with| %NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (LENGTH (|fetch| (ARRAY-HEADER FILL-POINTER) |of| DATUM) ((OPENLAMBDA (STRING NV) (|replace| (ARRAY-HEADER FILL-POINTER) |of| STRING |with| NV) (|replace| ( ARRAY-HEADER TOTAL-SIZE) |of| STRING |with| NV) (COND ((%GENERAL-ARRAY-P STRING) (|freplace| ( GENERAL-ARRAY DIMS) |of| STRING |with| (LIST NV)))) NV) DATUM NEWVALUE)) (OFFST ((OPENLAMBDA (STRING) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-OFFSET STRING)) (T (|fetch| ( ARRAY-HEADER OFFSET) |of| STRING)))) DATUM) ((OPENLAMBDA (STRING NV) (COND ((NOT (EQ 0 NV)) (|replace| (ARRAY-HEADER DISPLACED-P) |of| STRING |with| T))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%SET-ARRAY-OFFSET STRING NV)) (T (|replace| (ARRAY-HEADER OFFSET) |of| STRING |with| NV)))) DATUM NEWVALUE)) (* |;;| "The rest of these fields only appear when smashing") (XFLAGS (LOGAND ( |fetch| (ARRAY-HEADER FLAGS) |of| DATUM) 15) ((OPENLAMBDA (STRING) (|replace| (ARRAY-HEADER ADJUSTABLE-P) |of| STRING |with| NIL) (|replace| (ARRAY-HEADER DISPLACED-P) |of| STRING |with| NIL) ( |replace| (ARRAY-HEADER FILL-POINTER-P) |of| STRING |with| NIL) (|replace| (ARRAY-HEADER EXTENDABLE-P) |of| STRING |with| NIL)) DATUM))) (ACCESSFNS STRINGP ((ORIG ((OPENLAMBDA (STRING) 1) DATUM) (( OPENLAMBDA (STRING NV) (COND ((NOT (EQ NV 1)) (ERROR "Il:stringp's are always origin 1"))) NV) DATUM NEWVALUE)) (* \; "An inoperative field") (SUBSTRINGED ((OPENLAMBDA (STRING) NIL) DATUM) ((OPENLAMBDA ( STRING NV) (OR (NULL NV) (ERROR "Substringed field not supported"))) DATUM NEWVALUE)) (READONLY ( |ffetch| (STRINGP XREADONLY) |of| DATUM) (|freplace| (STRINGP XREADONLY) |of| DATUM |with| NEWVALUE)) (FATSTRINGP ((OPENLAMBDA (STRING) (EQ (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) ( %ARRAY-TYPE-NUMBER STRING)) (T (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| STRING))) %FAT-CHAR-TYPENUMBER )) DATUM) ((OPENLAMBDA (STRING NV) (LET ((%NEW-TYPE-NUMBER (COND (NV %FAT-CHAR-TYPENUMBER) (T %THIN-CHAR-TYPENUMBER)))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) ( %SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| STRING |with| %NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (BASE (|ffetch| (STRINGP XBASE) |of| DATUM) (|freplace| (STRINGP XBASE) |of| DATUM |with| NEWVALUE)))) (CREATE (|create| ONED-ARRAY BASE _ XBASE READ-ONLY-P _ XREADONLY STRING-P _ T DISPLACED-P _ (NOT (EQ OFFST 0)) TYPE-NUMBER _ (COND ((EQ TYP \\ST.POS16) %FAT-CHAR-TYPENUMBER) (T %THIN-CHAR-TYPENUMBER)) OFFSET _ OFFST FILL-POINTER _ LENGTH TOTAL-SIZE _ LENGTH)) (TYPE? (CL:STRINGP DATUM)) OFFST _ 0 TYP _ \\ST.BYTE LENGTH _ 0) (GLOBALVARS |\\OneCharAtomBase|) (PUTDEF (QUOTE \\NUMSTR) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING 128)))) (PUTDEF (QUOTE \\NUMSTR1) (QUOTE RESOURCES) (QUOTE (NEW (CONCAT)))) (PUTDEF (QUOTE \\PNAMESTRING) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING \\PNAMELIMIT NIL NIL \\FATPNAMESTRINGP)))) (RPAQQ \\FATPNAMESTRINGP T) (CONSTANTS (\\FATPNAMESTRINGP T)) (PUTPROPS \\PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* \; "For stuffing chars into resource \\PNAMESTRING") (\\PUTBASECHAR \\FATPNAMESTRINGP BASE OFFSET CODE))) (DEFOPTIMIZER FCHARACTER (NUM) (BQUOTE ((OPENLAMBDA (N) (COND ((IGREATERP N \\MAXTHINCHAR) (* \; "The character we're getting is NOT a thin character -- do it the hard way") (CHARACTER N)) (( IGREATERP N (CHARCODE 9)) (\\ADDBASE |\\OneCharAtomBase| (IDIFFERENCE N 10))) ((IGEQ N (CHARCODE 0)) ( IDIFFERENCE N (CHARCODE 0))) (T (* \; "The common case -- just add on the one-atom base.") (\\ADDBASE |\\OneCharAtomBase| N)))) (\\\, NUM)))) (I.S.OPR (QUOTE |inpname|) NIL (QUOTE (SUBPAIR (QUOTE ($$END $$BODY $$FATP $$BASE $$OFFSET)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (BQUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP |declare| (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET) |first| ( PROG NIL $$RETRY (COND ((STRINGP $$BODY) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$OFFSET (SUB1 (|ffetch| (STRINGP OFFST) |of| $$BODY))) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) (SETQ $$FATP (|ffetch| (STRINGP FATSTRINGP) |of| $$BODY))) ((LITATOM $$BODY) ( SETQ $$BASE (|ffetch| (LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) (SETQ $$FATP (|ffetch| (LITATOM FATPNAMEP) |of| $$BODY))) (T (SETQ $$BODY (MKSTRING $$BODY)) (GO $$RETRY)))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) ( GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET) ))))))) T) (I.S.OPR (QUOTE |inatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END $$FATP)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP) |first| ( SETQ $$BASE (|ffetch| (LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) (SETQ $$FATP (|ffetch| (LITATOM FATPNAMEP) |of| $$BODY)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET)))))))) T) (I.S.OPR (QUOTE |instring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE $$FATP)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP) |first| (SETQ $$OFFSET (SUB1 (|ffetch| (STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) (SETQ $$FATP (|ffetch| (STRINGP FATSTRINGP) |of| $$BODY)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET)))))))) T) (I.S.OPR (QUOTE |infatatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END) |first| (SETQ $$BASE (|ffetch| ( LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. ( \\GETBASEFAT $$BASE $$OFFSET)))))) T) (I.S.OPR (QUOTE |inthinatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END) |first| (SETQ $$BASE (|ffetch| ( LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. ( \\GETBASETHIN $$BASE $$OFFSET)))))) T) (I.S.OPR (QUOTE |infatstring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET $$BASE |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE) |first| (SETQ $$OFFSET (SUB1 (|ffetch| ( STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND ( IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\\GETBASEFAT $$BASE $$OFFSET)))))) T) (I.S.OPR (QUOTE |inthinstring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET $$BASE |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE) |first| (SETQ $$OFFSET (SUB1 (|ffetch| ( STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND ( IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\\GETBASETHIN $$BASE $$OFFSET)))))) T) (PUTPROPS \\CHARCODEP DMACRO (OPENLAMBDA (X) (* \; "used to also say (ILEQ X \\MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X) (IGEQ X 0)))) (PUTPROPS \\FATCHARCODEP DMACRO (OPENLAMBDA (X) (* \; "Used to also say (ILEQ X \\MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X) (IGREATERP X \\MAXTHINCHAR)))) (PUTPROPS \\THINCHARCODEP DMACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0) (ILEQ X \\MAXTHINCHAR)))) (PUTPROPS \\GETBASEFAT MACRO (= . \\GETBASE)) (PUTPROPS \\GETBASETHIN MACRO (= . \\GETBASEBYTE)) (PUTPROPS \\PUTBASEFAT MACRO (= . \\PUTBASE)) (PUTPROPS \\PUTBASETHIN MACRO (= . \\PUTBASEBYTE)) (PUTPROPS \\PUTBASECHAR MACRO (OPENLAMBDA (FATP BASE OFFSET CODE) (COND (FATP (\\PUTBASEFAT BASE OFFSET CODE)) (T (\\PUTBASETHIN BASE OFFSET CODE))))) (PUTPROPS \\GETBASECHAR MACRO ((FATP BASE N) (COND (FATP (\\GETBASEFAT BASE N)) (T (\\GETBASETHIN BASE N))))) (PUTPROPS \\CHARSET MACRO ((CHARCODE) (LRSH CHARCODE 8))) (PUTPROPS \\CHAR8CODE MACRO ((CHARCODE) (LOGAND CHARCODE 255))) (RPAQQ \\CHARMASK 255) (RPAQQ \\MAXCHAR 255) (RPAQQ \\MAXTHINCHAR 255) (RPAQQ \\MAXFATCHAR 65535) (RPAQQ \\MAXCHARSET 255) (RPAQQ NSCHARSETSHIFT 255) (RPAQQ \#STRINGPWORDS 4) (CONSTANTS (\\CHARMASK 255) (\\MAXCHAR 255) (\\MAXTHINCHAR 255) (\\MAXFATCHAR 65535) (\\MAXCHARSET 255 ) (NSCHARSETSHIFT 255) (\#STRINGPWORDS 4)) (PUTPROPS \\NATOMCHARS DMACRO ((AT) (|fetch| (LITATOM PNAMELENGTH) |of| AT))) (PUTPROPS \\NSTRINGCHARS DMACRO ((S) (|fetch| (STRINGP LENGTH) |of| S))) (PUTPROP (QUOTE LLCHAR) (QUOTE IMPORTDATE) (IDATE "11-Nov-2018 13:08:04")) (ACCESSFNS BF ((BFBLOCK (ADDSTACKBASE DATUM))) (* \; "basic frame pointer") (BLOCKRECORD BFBLOCK (( FLAGS BITS 3) (NIL BITS 3) (RESIDUAL FLAG) (* \; "true if this is not a full BF") (PADDING BITS 1) ( USECNT BITS 8) (IVAR WORD))) (TYPE? (IEQ (|fetch| (BF FLAGS) |of| DATUM) \\STK.BF)) (ACCESSFNS BF (( NARGS (IDIFFERENCE (FOLDLO (IDIFFERENCE DATUM (|fetch| (BF IVAR) |of| DATUM)) WORDSPERCELL) (|fetch| ( BF PADDING) |of| DATUM))) (SIZE (IPLUS 2 (IDIFFERENCE DATUM (|fetch| (BF IVAR) |of| DATUM)))) (CHECKED (AND (|type?| BF DATUM) (|for| I |from| (|fetch| (BF IVAR) |of| DATUM) |to| (IDIFFERENCE DATUM 2) |by| 2 |always| (IEQ \\STK.NOTFLAG (|fetch| (BF FLAGS) |of| I)))))))) (ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* \; "frame extension index") (BLOCKRECORD FXBLOCK (( FLAGS BITS 3) (* \; "= \\STK.FX") (FAST FLAG) (NIL FLAG) (INCALL FLAG) (* \; "set when fncall microcode has to punt") (VALIDNAMETABLE FLAG) (* \; "if on, NAMETABLE field is filled in. If off, is same as FNHEADER") (NOPUSH FLAG) (* \; "when returning to this frame, don't push a value. Set by interrupt code") (USECNT BITS 8) (\#ALINK WORD) (* \; "low bit is SLOWP") (FNHEADER FULLXPOINTER) (NEXTBLOCK WORD) (PC WORD) (NAMETABLE# FULLXPOINTER) (\#BLINK WORD) (\#CLINK WORD))) (BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE) (NIL BYTE) (NIL BITS 15) (* \; "most of the bits of #ALINK") (SLOWP FLAG) (* \; "if on, then BLINK and CLINK fields are valid. If off, they are implicit") (NIL FULLXPOINTER 2) ( NAMETABHI WORD) (NAMETABLO WORD))) (TYPE? (IEQ (|fetch| (FX FLAGS) |of| DATUM) \\STK.FX)) (ACCESSFNS FX ((NAMETABLE (COND ((|fetch| (FX VALIDNAMETABLE) |of| DATUM) (|fetch| (FX NAMETABLE#) |of| DATUM)) ( T (|fetch| (FX FNHEADER) |of| DATUM))) (PROGN (|replace| (FX FAST) |of| DATUM |with| NIL) (|replace| ( FX NAMETABLE#) |of| DATUM |with| NEWVALUE) (|replace| (FX VALIDNAMETABLE) |of| DATUM |with| T))) ( FRAMENAME (|fetch| (FNHEADER FRAMENAME) |of| (|fetch| (FX NAMETABLE) |of| DATUM))) (INVALIDP (EQ DATUM 0)) (* \; "true when A/CLink points at nobody, i.e. FX is bottom of stack") (FASTP (NOT (|fetch| (FX SLOWP) |of| DATUM)) (PROGN (CHECK (NULL NEWVALUE)) (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| ( FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX \#ALINK) |of| DATUM)) (|replace| (FX SLOWP) |of| DATUM |with| T))))) (BLINK (COND ((|fetch| (FX FASTP) |of| DATUM) (|fetch| (FX DUMMYBF) |of| DATUM)) (T (|fetch| (FX \#BLINK) |of| DATUM))) (PROGN (|replace| (FX \#BLINK) |of| DATUM |with| NEWVALUE) (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX \#ALINK) |of| DATUM)) (|replace| (FX SLOWP) |of| DATUM |with| T))))) (CLINK (IDIFFERENCE (COND ((|fetch| (FX FASTP) |of| DATUM) (|fetch| ( FX \#ALINK) |of| DATUM)) (T (|fetch| (FX \#CLINK) |of| DATUM))) \\#ALINK.OFFSET) (PROGN (|replace| (FX \#CLINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET)) (COND ((|fetch| (FX FASTP) |of| DATUM) ( |replace| (FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX SLOWP) |of| DATUM |with| T))))) (ALINK (IDIFFERENCE (FLOOR (|fetch| (FX \#ALINK) |of| DATUM) WORDSPERCELL) \\#ALINK.OFFSET) (PROGN (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX \#ALINK) |of| DATUM)))) (|replace| (FX \#ALINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET ( SUB1 WORDSPERCELL))))) (ACLINK (SHOULDNT) (PROGN (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)))) (|replace| (FX \#CLINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET)) (|replace| (FX \#ALINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET (SUB1 WORDSPERCELL))))) (* \; "replaces A & C Links at once more efficiently than separately") (DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL)) (* |;;| "This is either an actual BF or \"residual\" BF that provides enough BF to find its IVAR slot. This means that when a FX is copied, the cell preceding the FX is copied too." ) (IVAR (|fetch| (BF IVAR) |of| (|fetch| (FX DUMMYBF) |of| DATUM))) (CHECKED (AND (|type?| FX DATUM) ( OR (IEQ (|fetch| (FX DUMMYBF) |of| DATUM) (|fetch| (FX BLINK) |of| DATUM)) (AND (|fetch| (BF RESIDUAL) |of| (|fetch| (FX DUMMYBF) |of| DATUM)) (IEQ (|fetch| (BF IVAR) |of| (|fetch| (FX DUMMYBF) |of| DATUM )) (|fetch| (BF IVAR) |of| (|fetch| (FX BLINK) |of| DATUM))))))) (FIRSTPVAR (IPLUS DATUM (|fetch| (FX FXSIZE) |of| T))) (* \; "stack offset of PVAR0") (FXSIZE (PROGN 10)) (* \; "fixed overhead from flags thru clink") (PADDING (PROGN 4)) (* \; "doublecell of garbage for microcode use") (FIRSTTEMP (IPLUS (|fetch| (FX FIRSTPVAR) |of| DATUM) ( |fetch| (FX NPVARWORDS) |of| DATUM) (|fetch| (FX PADDING) |of| DATUM))) (* \; "note that NPVARWORDS is obtained from the FNHEADER") (SIZE (IDIFFERENCE (|fetch| (FX NEXTBLOCK) |of| DATUM) DATUM))))) (ACCESSFNS FSB (* |;;| "FREE STACK BLOCK -- ") (* |;;| " A piece of stack space that's free.") (* |;;| "The first word contains 120000Q") (* |;;| "The 2nd word is the size of the block, in words.") (( FSBBLOCK (ADDSTACKBASE DATUM)) (CHECKED (IEQ (|fetch| (FSB FLAGWORD) |of| DATUM) \\STK.FSB.WORD))) ( BLOCKRECORD FSBBLOCK ((FLAGS BITS 3) (DUMMY BITS 13) (SIZE WORD))) (BLOCKRECORD FSBBLOCK ((FLAGWORD WORD) (SIZE WORD))) (* \; "free stack block") (TYPE? (IEQ (|fetch| (FSB FLAGS) |of| DATUM) \\STK.FSB)) ) (ACCESSFNS STK ((STKBLOCK (ADDSTACKBASE DATUM))) (* \; "unspecified stack block") (BLOCKRECORD STKBLOCK ((FLAGS BITS 3))) (BLOCKRECORD STKBLOCK ((FLAGWORD WORD)))) (RPAQQ \\#ALINK.OFFSET 10) (CONSTANTS \\#ALINK.OFFSET) (GLOBALVARS \\PENDINGINTERRUPT \\KBDSTACKBASE \\MISCSTACKBASE \\STACKOVERFLOW) (PUTPROPS \\MYALINK DMACRO (NIL ((OPCODES MYALINK)))) (PUTPROPS ADDSTACKBASE DMACRO (= . STACKADDBASE)) (PUTPROPS STACKADDBASE DMACRO ((N) (VAG2 \\STACKHI N))) (PUTPROPS STACKGETBASE DMACRO ((N) (\\GETBASE (STACKADDBASE N) 0))) (PUTPROPS STACKGETBASEPTR DMACRO ((N) (\\GETBASEPTR (STACKADDBASE N) 0))) (PUTPROPS STACKPUTBASE DMACRO ((N V) (\\PUTBASE (STACKADDBASE N) 0 V))) (PUTPROPS STACKPUTBASEPTR DMACRO ((N V) (\\PUTBASEPTR (STACKADDBASE N) 0 V))) (PUTPROPS \\MISCAPPLY* MACRO ((FN ARG1 ARG2) (UNINTERRUPTABLY (|replace| (IFPAGE MISCSTACKFN) |of| |\\InterfacePage| |with| FN) (|replace| (IFPAGE MISCSTACKARG1) |of| |\\InterfacePage| |with| ARG1) ( |replace| (IFPAGE MISCSTACKARG2) |of| |\\InterfacePage| |with| ARG2) (\\CONTEXTSWITCH |\\MiscFXP|) ( |fetch| (IFPAGE MISCSTACKRESULT) |of| |\\InterfacePage|)))) (BLOCKRECORD STACKP ((STACKP0 WORD) (EDFXP WORD)) (BLOCKRECORD STACKP ((STACKPOINTER FULLXPOINTER))) ( TYPE? (STACKP DATUM))) (RPAQQ STACKTYPES (\\STK.GUARD \\STK.FX \\STK.BF \\STK.NOTFLAG \\STK.FSB \\STK.FLAGS.SHIFT ( \\STK.FSB.WORD (LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (\\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT)) (\\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT)))) (RPAQQ \\STK.GUARD 7) (RPAQQ \\STK.FX 6) (RPAQQ \\STK.BF 4) (RPAQQ \\STK.NOTFLAG 0) (RPAQQ \\STK.FSB 5) (RPAQQ \\STK.FLAGS.SHIFT 13) (RPAQ \\STK.FSB.WORD (LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (RPAQ \\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT)) (RPAQ \\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT)) (CONSTANTS \\STK.GUARD \\STK.FX \\STK.BF \\STK.NOTFLAG \\STK.FSB \\STK.FLAGS.SHIFT (\\STK.FSB.WORD ( LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (\\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT)) ( \\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT))) (RPAQQ |\\StackAreaSize| 768) (RPAQ |\\InitStackSize| (ITIMES |\\StackAreaSize| 12)) (CONSTANTS |\\StackAreaSize| (|\\InitStackSize| (ITIMES |\\StackAreaSize| 12))) (RPAQQ \\MAXSAFEUSECOUNT 200) (CONSTANTS \\MAXSAFEUSECOUNT) (BLOCKRECORD NAMETABLESLOT ((VARTYPE BYTE) (VAROFFSET BYTE))) (BLOCKRECORD FVARSLOT ((BINDLO WORD) (BINDHI WORD)) (ACCESSFNS FVARSLOT ((LOOKEDUP (EVENP (|fetch| BINDLO |of| DATUM))) (BINDINGPTR (\\VAG2 (|fetch| BINDHI |of| DATUM) (|fetch| BINDLO |of| DATUM)) ( PROGN (|replace| BINDLO |of| DATUM |with| (\\LOLOC NEWVALUE)) (|replace| BINDHI |of| DATUM |with| ( \\HILOC NEWVALUE))))))) (BLOCKRECORD PVARSLOT ((PVHI BITS 4) (PVVALUE XPOINTER)) (ACCESSFNS PVARSLOT ((BOUND (EQ (|fetch| ( PVARSLOT PVHI) |of| DATUM) 0) (|if| (NULL NEWVALUE) |then| (|replace| (PVARSLOT PVHI) |of| DATUM |with| 255) |else| (ERROR "Illegal replace" NEWVALUE)))))) (BLOCKRECORD STKTEMPSLOT ((STKTMPHI BITS 4) (VALUE XPOINTER)) (ACCESSFNS STKTEMPSLOT ((BINDINGPTRP ( NEQ (|fetch| STKTMPHI |of| DATUM) 0))))) (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* \; "Value stored in high half is one's complement of number of values bound") (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535)))))) (RPAQQ \\NT.IVAR 0) (RPAQQ \\NT.PVAR 128) (RPAQQ \\NT.FVAR 192) (CONSTANTS \\NT.IVAR \\NT.PVAR \\NT.FVAR) (PUTPROP (QUOTE LLSTK) (QUOTE IMPORTDATE) (IDATE " 6-Jan-1993 18:07:37")) (PUTPROPS WORDCONTENTS BYTEMACRO ((PTR) (\\GETBASE PTR 0))) (PUTPROPS SETWORDCONTENTS BYTEMACRO ((PTR N) (\\PUTBASE PTR 0 N))) (PUTPROPS WORDOFFSET BYTEMACRO ((PTR N) (\\ADDBASE PTR N))) (PUTPROPS \\RELEASECPAGE MACRO ((STREAM) (PROGN (* \; "Must be under an UNINTERRUPTABLY !") (COND (( |fetch| CBUFDIRTY |of| STREAM) (\\SETIODIRTY STREAM (|fetch| CPAGE |of| STREAM)) (|replace| CBUFDIRTY |of| STREAM |with| NIL))) (|replace| CBUFSIZE |of| STREAM |with| 0) (|replace| CBUFPTR |of| STREAM |with| NIL)))) (PUTPROP (QUOTE PMAP) (QUOTE IMPORTDATE) (IDATE " 3-Feb-2002 14:11:02")) (PUTPROPS ADDREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\\ADDREF PTR)))) (PUTPROPS \\ADDREF DMACRO ((X) ((OPCODES GCREF 0) X))) (PUTPROPS DELETEREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\\DELREF PTR)))) (PUTPROPS \\DELREF DMACRO ((X) ((OPCODES GCREF 1) X))) (PUTPROPS SCANREF MACRO (= . \\STKREF)) (PUTPROPS \\STKREF DMACRO ((X) ((OPCODES GCREF 2) X))) (PUTPROPS UNSCANREF MACRO ((PTR) (\\HTFIND PTR 3))) (PUTPROPS CREATEREF MACRO (= . \\CREATEREF)) (PUTPROPS \\CREATEREF MACRO (OPENLAMBDA (PTR) (PROG1 (\\DELREF PTR) (.INCREMENT.ALLOCATION.COUNT. 1))) ) (PUTPROPS .INCREMENT.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \\RECLAIM.COUNTDOWN) ) (AND \\RECLAIM.COUNTDOWN (COND ((IGREATERP \\RECLAIM.COUNTDOWN N) (SETQ \\RECLAIM.COUNTDOWN ( IDIFFERENCE \\RECLAIM.COUNTDOWN N))) (T (SETQ \\RECLAIM.COUNTDOWN) (\\DORECLAIM)))))) (PUTPROPS .CHECK.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \\RECLAIM.COUNTDOWN)) ( AND \\RECLAIM.COUNTDOWN (COND ((NOT (IGREATERP \\RECLAIM.COUNTDOWN N)) (SETQ \\RECLAIM.COUNTDOWN) ( \\DORECLAIM)))))) (PUTPROPS \\GCDISABLED MACRO (NIL (PROGN (DECLARE (GLOBALVARS \\GCDISABLED)) \\GCDISABLED))) (BLOCKRECORD HTOVERFLOW ((CASE BITS 4) (PTR XPOINTER)) (ACCESSFNS HTOVERFLOW ((CLEAR NIL (\\PUTBASEPTR DATUM 0 NIL))))) (BLOCKRECORD GC ((CNT BITS 15) (STKBIT FLAG) (HIBITS BITS 15) (LINKP FLAG) (NXTPTR FIXP)) (BLOCKRECORD GC ((STKCNT WORD))) (ACCESSFNS GC ((EMPTY (EQ 0 (\\GETBASEFIXP DATUM 0)) (\\PUTBASEFIXP DATUM 0 0)) ( CONTENTS (\\GETBASEFIXP DATUM 0) (\\PUTBASEFIXP DATUM 0 NEWVALUE)) (LINKPTR (LOGAND (\\GETBASEFIXP DATUM 0) -2) (\\PUTBASEFIXP DATUM 0 (LOGOR NEWVALUE 1)))))) (BLOCKRECORD HTCOLL ((* |;;| "An entry in the GC collision table. NEXTFREE is initialized to 2 by INITGC, as part of the MAKEINIT." ) (FREEPTR FIXP) (* \; "The GC table entry") (NEXTFREE FIXP) (* \; "If the entry is in use, points to the next entry in this collision chain. If not, offset (in 1/2-entries) of the next free one on the chain." ))) (PUTPROP (QUOTE LLGC) (QUOTE IMPORTDATE) (IDATE "19-Oct-1994 12:30:11")) (PUTPROPS \\SYNCODE DMACRO (OPENLAMBDA (TABLE CHAR) (CHECK (|type?| CHARTABLE TABLE)) (* \; "0 is either NONE.TC, REAL.CCE, or OTHER.RC") (COND ((IGREATERP CHAR \\MAXTHINCHAR) (OR (AND (|fetch| (CHARTABLE NSCHARHASH) |of| TABLE) (GETHASH CHAR (|fetch| (CHARTABLE NSCHARHASH) |of| TABLE))) 0)) (T (\\GETBASEBYTE TABLE CHAR))))) (PUTPROPS \\SETSYNCODE DMACRO (LAMBDA (TABLE CHAR CODE) (CHECK (|type?| CHARTABLE TABLE)) (* \; "0 is REAL.CCE, NONE.TC, OTHER.RC") (COND ((ILEQ CHAR \\MAXTHINCHAR) (\\PUTBASEBYTE TABLE CHAR CODE)) (T (\\SETFATSYNCODE TABLE CHAR CODE))))) (DATATYPE CHARTABLE ((CHARSET0 256 BYTE) (NSCHARHASH FULLPOINTER))) (RPAQQ CCECHOMODES (REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)) (RPAQQ REAL.CCE 0) (RPAQQ IGNORE.CCE 8) (RPAQQ SIMULATE.CCE 16) (RPAQQ INDICATE.CCE 24) (CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE) (RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC)) (RPAQQ NONE.TC 0) (RPAQQ EOL.TC 1) (RPAQQ CHARDELETE.TC 2) (RPAQQ WORDDELETE.TC 6) (RPAQQ WORDSEPR.TC 7) (RPAQQ LINEDELETE.TC 3) (RPAQQ RETYPE.TC 4) (RPAQQ CTRLV.TC 5) (CONSTANTS NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC) (ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24)) (TERMCLASS (LOGAND DATUM 7))) (* \; "We assume that values are appropriately shifted") (CREATE (LOGOR CCECHO TERMCLASS))) (DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL ( CONTROLFLG FLAG) (ECHOFLG FLAG)) TERMSA _ (|create| CHARTABLE)) (PUTPROPS \\GETREADMACRODEF MACRO ((C TBL) (GETHASH C (|fetch| READMACRODEFS |of| TBL)))) (PUTPROPS \\GTREADTABLE MACRO (ARGS (COND ((LITATOM (CAR ARGS)) (SUBPAIR (QUOTE (X . FLG)) ARGS (QUOTE (SELECTQ X ((NIL T) (\\DTEST *READTABLE* (QUOTE READTABLEP))) (\\GTREADTABLE1 X . FLG))))) (T (QUOTE IGNOREMACRO))))) (PUTPROPS \\GTREADTABLE1 DMACRO (ARGS (COND ((NULL (CDR ARGS)) (LIST (QUOTE \\DTEST) (CAR ARGS) (QUOTE (QUOTE READTABLEP)))) (T (QUOTE IGNOREMACRO))))) (RPAQQ MACROBIT 8) (RPAQQ BREAKBIT 16) (RPAQQ STOPATOMBIT 32) (RPAQQ ESCAPEBIT 64) (RPAQQ INNERESCAPEBIT 4) (CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT) (RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2)))) (RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (RPAQ WAKEUPMASK (LOGOR MACROBIT 2)) (CONSTANTS (CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2))) (RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) (ALONE.RMC (LOGOR MACROBIT 1)))) (RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (RPAQ FIRST.RMC (LOGOR MACROBIT 0)) (RPAQ ALONE.RMC (LOGOR MACROBIT 1)) (CONSTANTS (ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) ( ALONE.RMC (LOGOR MACROBIT 1))) (RPAQQ READCLASSES ((OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) ( LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)))) (RPAQQ OTHER.RC 0) (RPAQ SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (RPAQ BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (RPAQ STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (RPAQ LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RPAQ RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (RPAQ LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RPAQ RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (RPAQ ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (RPAQ MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (RPAQ PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)) (CONSTANTS (OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (LEFTPAREN.RC ( LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) ( LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))) (RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0)))) (RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2)) (RPAQ NONIMMEDIATE.RMW (LOGOR MACROBIT 0)) (CONSTANTS (IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0))) (RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT) (NOESC.RME 0))) (RPAQ ESC.RME ESCAPEBIT) (RPAQQ NOESC.RME 0) (CONSTANTS (ESC.RME ESCAPEBIT) (NOESC.RME 0)) (ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT)) (ESCQUOTE (BITTEST DATUM ESCAPEBIT)) (STOPATOM (BITTEST DATUM STOPATOMBIT)) (INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT))) ( MACROCONTEXT (LOGAND DATUM CONTEXTMASK)) (MACROP (BITTEST DATUM MACROBIT)) (WAKEUP (LOGAND DATUM WAKEUPMASK)) (BREAK (BITTEST DATUM BREAKBIT)))) (RECORD READMACRODEF (MACROTYPE . MACROFN)) (DATATYPE READTABLEP ((READSA POINTER) (* \; "A CHARTABLE defining syntax of each char") ( READMACRODEFS POINTER) (* \; "A hash table associating macro chars with macro definitions") ( READMACROFLG FLAG) (* \; "True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)") (ESCAPEFLG FLAG) (* \; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)" ) (COMMONLISP FLAG) (* \; "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules") (NUMBERBASE BITS 5) (* \; "Not used") (CASEINSENSITIVE FLAG) (* \; "If true, unescaped lowercase chars are converted to uppercase in symbols") (COMMONNUMSYNTAX FLAG) (* \; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers" ) (USESILPACKAGE FLAG) (* \; "If true, IL:READ ignores *PACKAGE* and reads in the IL package") (NIL 5 FLAG) (DISPATCHMACRODEFS POINTER) (* \; "An a-list of dispatching macro char and its dispatch definitions") (HASHMACROCHAR BYTE) (* \; "The character code used in this read table for the # dispatch macro") (ESCAPECHAR BYTE) (* \; "The character code used in this read table for single escape") (MULTESCAPECHAR BYTE) (* \; "The character code used in this read table for multiple escape") (PACKAGECHAR BYTE) (* \; "The character code used in this read table for package delimiter") (READTBLNAME POINTER) (* \; "The canonical 'name' of this read table")) READSA _ (|create| CHARTABLE)) (PUTPROP (QUOTE ATBL) (QUOTE IMPORTDATE) (IDATE "20-Apr-2018 17:35:56")) (DATATYPE STREAM ((* |;;| "First 8 words are fixed for BIN, BOUT opcodes. Used to require length of whole datatype be multiple of 4, but Dolphin dead now." ) (COFFSET WORD) (* \; "Offset in CPPTR of next bin or bout") (CBUFSIZE WORD) (* \; "Offset past last byte in that buffer") (PEEKEDCHARP FLAG) (* \; "if true, PEEKEDCHAR contains value of recent call to unread-char") (ACCESSBITS BITS 3) (* \; "What kind of access file is open for (read, write, append)") (CBUFPTR POINTER) (* \; "Pointer to current buffer") (BYTESIZE BYTE) (* \; "Byte size of stream, always 8 for now") (CHARSET BYTE) (* \; "the current character set for this stream. If 255, stream is not runcoded, so read-char consumes two bytes every time" ) (PEEKEDCHAR WORD) (* \; "value of unread-char call") (CHARPOSITION WORD) (* \; "Used by POSITION etc.") (CBUFMAXSIZE WORD) (* \; "on output, the size of the physical buffer--can't extend beyond this") (* |;;| "-------- Above fields (8 words) potentially known to microcode. --------") (NONDEFAULTDATEFLG FLAG) (REVALIDATEFLG FLAG) (MULTIBUFFERHINT FLAG) (* \; "True if stream likes to read and write more than one buffer at a time") (USERCLOSEABLE FLAG) (* \; "Can be closed by CLOSEF; NIL for terminal, dribble...") (FULLFILENAME POINTER) (* \; "Name by which file is known to user") (BINABLE FLAG) (* \; "BIN punts unless this bit on") (BOUTABLE FLAG) (* \; "BOUT punts unless this bit on") (EXTENDABLE FLAG) (* \; "BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512") (CBUFDIRTY FLAG) (* \; "true if BOUT has sullied the current buffer") (DEVICE POINTER) (* \; "FDEV of this guy") (USERVISIBLE FLAG) (* \; "Listed by OPENP; NIL for terminal, dribble ...") (EOLCONVENTION BITS 2) (* \; "End-of-line convention") (NOTXCCS FLAG) (* \; "True if the character encoding format is not XCCS.") ( VALIDATION POINTER) (* \; "A number somehow identifying file, used to determine if file has changed in our absence") (CPAGE POINTER) (* \; "CPAGE,,COFFSET constitutes current file pointer for most randaccess streams") (EPAGE POINTER) (EOFFSET WORD) (* \; "Page, byte offset of eof") (LINELENGTH WORD) (* \; "LINELENGTH of stream, or -1 for no line length") (* |;;| "----Following are device-specific fields----") (* |;;| "Available for device-specific uses, NOT for application use.") (F1 POINTER) (F2 POINTER) (F3 POINTER) (F4 POINTER) (F5 POINTER) (FW6 WORD) (FW7 WORD) (FW8 WORD) (FW9 WORD) (F10 POINTER) (* |;;| "----Following only filled in for open streams----") (STRMBINFN POINTER) (* \; "Either the BIN fn from the FDEV, or a trap") (STRMBOUTFN POINTER) (* \; "Either the BIN fn from the FDEV, or a trap") (OUTCHARFN POINTER) (* \; "Called by \\OUTCHAR, the normal character printer.") (ENDOFSTREAMOP POINTER) (* \; "Called if EOF and we try to read.") (OTHERPROPS POINTER) (* \; "PROP LIST for holding other info.") ( IMAGEOPS POINTER) (* \; "Image operations vector") (IMAGEDATA POINTER) (* \; "Image instance variables--format depends on IMAGEOPS value") (BUFFS POINTER) (* \; "Buffer chain for pmapped streams") (MAXBUFFERS WORD) (* \; "Max # of buffers the system will allocate.") (LASTCCODE WORD) (* \; "After READ, RATOM, etc, the charcode that will be returned (as a character) by LASTC. If there is none, this field is 65535." ) (EXTRASTREAMOP POINTER) (* \; "For use of applications programs, not devices")) (BLOCKRECORD STREAM ((NIL 2 WORD) (UCODEFLAGS1 BITS 1) (* |;;| "respecification of access bits:") (RANDOMWRITEABLE FLAG) ( * \; "File open for output (access = OUTPUT or BOTH)") (APPENDABLE FLAG) (* \; "File open for append (OUTPUT or APPEND or BOTH)") (READABLE FLAG) (* \; "File open for read (READ or BOTH)") (NIL POINTER))) (BLOCKRECORD STREAM ((NIL 4 WORD) (NIL BITS 14) ( * |;;| "JIS character encoding format specific, overrides CHARSET field.") (IN.KANJIIN FLAG) (* \; "True if input stream is in Kanji-in mode.") (OUT.KANJIIN FLAG) (* \; "True if output stream is in Kanji-in mode."))) (ACCESSFNS STREAM ((ACCESS \\GETACCESS \\SETACCESS) ( FULLNAME (OR (|fetch| (STREAM FULLFILENAME) |of| DATUM) DATUM)) (NAMEDP (AND (|fetch| (STREAM FULLFILENAME) |of| DATUM) T)))) (ACCESSFNS STREAM (EXTERNALFORMAT (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)) (LET ((PROPS (|ffetch| (STREAM OTHERPROPS) |of| DATUM) )) (|freplace| (STREAM NOTXCCS) |of| DATUM |with| T) (COND (PROPS (LISTPUT PROPS (QUOTE EXTERNALFORMAT ) NEWVALUE)) (T (|freplace| (STREAM OTHERPROPS) |of| DATUM |with| (LIST (QUOTE EXTERNALFORMAT) NEWVALUE)))) (|freplace| (STREAM OUTCHARFN) |of| DATUM |with| (|ffetch| (EXTERNALFORMAT FILEOUTCHARFN) |of| NEWVALUE)) (AND (|ffetch| (EXTERNALFORMAT EOLVALID) |of| NEWVALUE) (|freplace| (STREAM EOLCONVENTION) |of| DATUM |with| (|ffetch| (EXTERNALFORMAT EOL) |of| NEWVALUE)))))) (ACCESSFNS STREAM (EXTERNALFORMAT.NAME (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT.NAME)) ( LET ((PROPS (|ffetch| (STREAM OTHERPROPS) |of| DATUM)) (NAME (COND ((LITATOM NEWVALUE) NEWVALUE) (T ( MKATOM NEWVALUE))))) (|freplace| (STREAM NOTXCCS) |of| DATUM |with| T) (COND (PROPS (LISTPUT PROPS ( QUOTE EXTERNALFORMAT.NAME) NAME)) (T (|freplace| (STREAM OTHERPROPS) |of| DATUM |with| (LIST (QUOTE EXTERNALFORMAT.NAME) NAME))))))) (ACCESSFNS STREAM (INCCODEFN (LET ((XFMT (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch| ( EXTERNALFORMAT INCCODEFN) |of| XFMT))))) (ACCESSFNS STREAM (PEEKCCODEFN (LET ((XFMT (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch| (EXTERNALFORMAT PEEKCCODEFN) |of| XFMT))))) (ACCESSFNS STREAM (BACKCHARFN (LET ((XFMT (LISTGET ( |ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch| (EXTERNALFORMAT BACKCHARFN) |of| XFMT))))) (ACCESSFNS STREAM (FILEOUTCHARFN (|ffetch| (STREAM OUTCHARFN) |of| DATUM))) (SYNONYM CBUFPTR (CPPTR)) USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ |NoBits| CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE ( GLOBALVARS \\STREAM.DEFAULT.MAXBUFFERS)) \\STREAM.DEFAULT.MAXBUFFERS) CHARPOSITION _ 0 LINELENGTH _ ( LET NIL (DECLARE (GLOBALVARS FILELINELENGTH)) FILELINELENGTH) OUTCHARFN _ (FUNCTION \\FILEOUTCHARFN) ENDOFSTREAMOP _ (FUNCTION \\EOSERROR) IMAGEOPS _ \\NOIMAGEOPS EOLCONVENTION _ (SELECTQ (SYSTEMTYPE) (D CR.EOLC) (VAX LF.EOLC) (JERICHO CRLF.EOLC) CR.EOLC) STRMBINFN _ (FUNCTION \\STREAM.NOT.OPEN) STRMBOUTFN _ (FUNCTION \\STREAM.NOT.OPEN) LASTCCODE _ 65535 NOTXCCS _ NIL) (PUTPROPS STREAMOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) ( QUOTE QUOTE)) (LIST (QUOTE |fetch|) (CADAR ARGS) (QUOTE |of|) (CADR ARGS))) (T (HELP "STREAMOP - OPNAME not quoted:" ARGS))) (CDDR ARGS))))) (RPAQQ |AppendBit| 2) (RPAQQ |NoBits| 0) (RPAQQ |ReadBit| 1) (RPAQQ |WriteBit| 4) (RPAQ |OutputBits| (LOGOR |AppendBit| |WriteBit|)) (RPAQ |BothBits| (LOGOR |ReadBit| |OutputBits|)) (RPAQQ \\NORUNCODE 255) (CONSTANTS |AppendBit| |NoBits| |ReadBit| |WriteBit| (|OutputBits| (LOGOR |AppendBit| |WriteBit|)) ( |BothBits| (LOGOR |ReadBit| |OutputBits|)) \\NORUNCODE) (PUTPROPS |TestMasked| MACRO ((BITS MASK) (NEQ (LOGAND BITS MASK) 0))) (PUTPROPS APPENDABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |AppendBit|))) (PUTPROPS APPENDONLY MACRO ((STREAM) (EQ (|fetch| ACCESSBITS |of| STREAM) |AppendBit|))) (PUTPROPS DIRTYABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) (CONSTANT (LOGOR |AppendBit| |WriteBit|))))) (PUTPROPS OPENED MACRO ((STREAM) (NEQ (|fetch| ACCESSBITS |of| STREAM) |NoBits|))) (PUTPROPS OVERWRITEABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |WriteBit|))) (PUTPROPS READABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |ReadBit|))) (PUTPROPS READONLY MACRO ((STREAM) (EQ (|fetch| ACCESSBITS |of| STREAM) |ReadBit|))) (PUTPROPS WRITEABLE MACRO ((STREAM) (OR (OVERWRITEABLE STREAM) (AND (APPENDABLE STREAM) (\\EOFP STREAM ))))) (PUTPROPS \\RUNCODED MACRO (OPENLAMBDA (STREAM) (* |;;| "returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented" ) (* \; "note that neq is ok since charsets are known to be SMALLP's") (NEQ (|fetch| CHARSET |of| STREAM) \\NORUNCODE))) (RPAQQ EOLCONVENTIONS ((CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2))) (RPAQQ CR.EOLC 0) (RPAQQ LF.EOLC 1) (RPAQQ CRLF.EOLC 2) (CONSTANTS (CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2)) (PUTPROPS FDEVOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS)) ) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (|fetch| (FDEV ( \\\, (CADR OPNAME))) |of| (\\\, METHOD-DEVICE)) (\\\,@ TAIL)))) (T (ERROR "OPNAME not quoted: " OPNAME )))))) (PUTPROPS \\RECOGNIZE-HACK DMACRO (ARGS (LET ((NAME (CAR ARGS)) (RECOG (CADR ARGS)) (DEVICE (CADDR ARGS))) (BQUOTE (|if| (|type?| STREAM (\\\, NAME)) |then| (\\\, NAME) |else| (FDEVOP (QUOTE GETFILENAME) (\\\, DEVICE) (\\\, NAME) (\\\, RECOG) (\\\, DEVICE))))))) (DATATYPE FDEV ((RESETABLE FLAG) (* \; "Obsolete") (RANDOMACCESSP FLAG) (NODIRECTORIES FLAG) ( PAGEMAPPED FLAG) (* \; "True if i/o handled by pmap routines") (FDBINABLE FLAG) (* \; "Copied as a microcode flag for INPUT streams formed on this device") (FDBOUTABLE FLAG) (FDEXTENDABLE FLAG) (BUFFERED FLAG) (* \; "True implies that the device supports the BIN & BOUT uCode conventions, and implements the GETNEXTBUFFER method" ) (DEVICENAME POINTER) (* \; "Identifying name somehow") (REMOTEP FLAG) (* \; "true if device not local to machine") (SUBDIRECTORIES FLAG) (* \; "true if device has real subdirectories") (INPUT-INDIRECTED FLAG) (* \; "True for devices that indirect their input stream. Method INPUTSTREAM fetches it") ( OUTPUT-INDIRECTED FLAG) (* \; "True for devices that indirect their output stream. Method OUTPUTSTREAM fetches it") (DEVICEINFO POINTER) (* \; "arbitrary device-specific info stored here") (OPENFILELST POINTER) (* \; "Default place to keep list of streams open on this device") (* |;;| "-----Rest of record consists of device \"methods\"-----") (* |;;| "-----Following fields required of all devices-----") (HOSTNAMEP POINTER) (* \; "(hostname {device}) => T if hostname is valid. If device is given, return a FDEV for this {new} host, or T to use existing device" ) (EVENTFN POINTER) (* \; "(device event), called before/after logout, sysout, makesys") (* |;;| "-----Following fields required of all named devices, e.g., ones that open files-----") ( DIRECTORYNAMEP POINTER) (* \; "(host/dir) => true if directory exists on host") (OPENFILE POINTER) (* \; "(name access recog otherinfo device) => new stream open on this device, or NIL if name not found") (CLOSEFILE POINTER) (* \; "(stream) => closes stream, returns it") (REOPENFILE POINTER) (* \; "(name access recog otherinfo device stream) like openfile, but called after logout to revalidate file, so optionally uses info in old stream to keep this opening like the previous" ) (GETFILENAME POINTER) (* \; "(name recog device) => full file name") (DELETEFILE POINTER) (* \; "(name) => deletes file so named, returning name, or NIL on failure. RECOG=OLDEST") (GENERATEFILES POINTER) (* \; "(device pattern) => generator object for files matching pattern. Car of object is generator function, cdr is arbitrary state. Generator fn returns next file, or NIL when finished" ) (RENAMEFILE POINTER) (* \; "(olddevice oldfile newdevice newfile) to rename file on this (olddevice) to a potentially different device." ) (OPENP POINTER) (* \; "(name access dev) => stream if name is open for access, or all open streams if name = NIL") ( REGISTERFILE POINTER) (* \; "(stream dev) => registers stream on its device") (UNREGISTERFILE POINTER) (* \; "(stream dev) => unregisters a stream from its device") (FREEPAGECOUNT POINTER) (* \; "(host/dir dev) => # of free pages on host/dir") (MAKEDIRECTORY POINTER) (* \; "(host/dir dev)") ( CHECKFILENAME POINTER) (* \; "(name dev) => name if it is well-formed file name for dev") (HOSTALIVEP POINTER) (* \; "(host dev) => true if host is alive, i.e., responsive; only defined if REMOTEP is true") ( BREAKCONNECTION POINTER) (* \; "(host fastp dev) => closes connections to host") (* |;;| "-----The following are required methods for operating on open streams-----") (BIN POINTER) (* \; "(stream) => next byte of input") (BOUT POINTER) (* \; "(stream byte) output byte to stream") (PEEKBIN POINTER) (* \; "(stream) => next byte without advancing position in stream") (READCHAR POINTER) (* \; "(stream) => next input char") (WRITECHAR POINTER) (* \; "(stream char) => writes char to stream") ( PEEKCHAR POINTER) (UNREADCHAR POINTER) (READP POINTER) (* \; "(stream flag) => T if there is input available from stream right now") (EOFP POINTER) (* \; "(stream) => T if BIN would signal eof.") (BLOCKIN POINTER) (* \; "(stream buffer byteoffset nbytes)") (BLOCKOUT POINTER) (* \; "(stream buffer byteoffset nbytes)") (FORCEOUTPUT POINTER) (* \; "(stream waitForFinish) flushes out to device anything that is buffered awaiting transmission") ( GETFILEINFO POINTER) (* \; "(stream/name attribute device) => value of attribute for open stream or name of closed file") ( SETFILEINFO POINTER) (* \; "(stream/name attribute newvalue device) sets attribute of open stream or closed file of given name") (CHARSETFN POINTER) (* \; "(stream charset) => access function for the charset slot, for benefit of indirect streams. See IMCHARSET for changing it on a file." ) (INPUTSTREAM POINTER) (* \; "(stream) => indirected input stream") (OUTPUTSTREAM POINTER) (* \; "(stream) => indirected output stream") (* |;;| "-----Following are required of random-access streams-----") (GETFILEPTR POINTER) (GETEOFPTR POINTER) (SETFILEPTR POINTER) (BACKFILEPTR POINTER) (* \; "(stream) backs up `fileptr' by one. Stream is only required to be able to do this once, i.e. one-character buffer suffices" ) (SETEOFPTR POINTER) (* \; "(stream length) => truncates or lengthens stream to indicated length") ( LASTC POINTER) (* \; "Should be possible only if RANDOMACCESSP") (* |;;| "-----Following used for buffered streams-----") (GETNEXTBUFFER POINTER) (* \; "(stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next. whatfor is READ or WRITE. Can cause EOF error unless noerrorflg" ) (RELEASEBUFFER POINTER) (* \; "(stream) => Does whatever appropriate when CBUFPTR is released") (* |;;| "-----Following used for pagemapped streams-----") (READPAGES POINTER) (* \; "(stream firstpage# buflist) => # of bytes read, starting at firstpage#, reading into buflist, a list of buffers or a single buffer (the usual case)" ) (WRITEPAGES POINTER) (* \; "(stream firstpage# buflist) writes from buflist to stream starting at firstpage# of stream") ( TRUNCATEFILE POINTER) (* \; "(stream page offset) make stream's eof be at page,offset, discarding anything after it") (* |;;| "-----For window system, argh-----") (WINDOWOPS POINTER) (* \; "window system operations") (WINDOWDATA POINTER) (* \; "data for window systems") (* |;;| "-----For any stream (here to not recompile everything)-----") (READCHARCODE POINTER) (* \; "Read a character code from the stream (cf BIN for bytes).")) DIRECTORYNAMEP _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) READP _ (FUNCTION \\GENERIC.READP) SETFILEPTR _ (FUNCTION \\IS.NOT.RANDACCESSP) GETFILEPTR _ (FUNCTION \\ILLEGAL.DEVICEOP) GETEOFPTR _ (FUNCTION \\IS.NOT.RANDACCESSP) EOFP _ (FUNCTION \\ILLEGAL.DEVICEOP) BLOCKIN _ (FUNCTION \\GENERIC.BINS) BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS) RENAMEFILE _ (FUNCTION \\GENERIC.RENAMEFILE) FORCEOUTPUT _ ( FUNCTION NILL) REGISTERFILE _ (FUNCTION NILL) OPENP _ (FUNCTION NILL) UNREGISTERFILE _ (FUNCTION NILL) READCHAR _ (FUNCTION \\GENERIC.READCHAR) WRITECHAR _ (FUNCTION \\GENERIC.WRITECHAR) PEEKCHAR _ ( FUNCTION \\GENERIC.PEEKCHAR) UNREADCHAR _ (FUNCTION \\GENERIC.UNREADCHAR) CHARSETFN _ (FUNCTION \\GENERIC.CHARSET) BREAKCONNECTION _ (FUNCTION NILL) READCHARCODE _ (FUNCTION \\GENERIC.READCCODE)) (RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE)) (DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (* \; "If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream.") (EOL BITS 2) (NIL BITS 1) (INCCODEFN POINTER) (* \; "Called with two arguments -- STREAM and COUNTP") ( PEEKCCODEFN POINTER) (* \; "Called with three arguments -- STREAM, NOERROR and COUNTP") (BACKCHARFN POINTER) (* \; "Called with two arguments -- STREAM and COUNTP") (FILEOUTCHARFN POINTER) (* \; "Called with two arguments -- STREAM and CHARCODE")) EOLVALID _ NIL) (PUTPROPS \\OUTCHAR DMACRO (OPENLAMBDA (STREAM CHARCODE) (STREAMOP (QUOTE OUTCHARFN) STREAM STREAM CHARCODE))) (PUTPROPS \\DEVICE-OPEN-STREAMS MACRO (ARGS (LET ((DEVICE (CAR ARGS))) (BQUOTE (FDEVOP (QUOTE OPENP) ( \\\, DEVICE) NIL NIL (\\\, DEVICE)))))) (PUTPROPS \\CONVERT-PATHNAME DMACRO (OPENLAMBDA (PATHNAME?) (* |;;| "Coerce pathnames to Interlisp strings, for the benefit of antediluvian Interlisp-D file fns") ( CL:TYPECASE PATHNAME? (PATHNAME (INTERLISP-NAMESTRING PATHNAME?)) (T PATHNAME?)))) (DEFOPTIMIZER ACCESS-CHARSET (STREAM &OPTIONAL NEWVALUE) (BQUOTE ((OPENLAMBDA (STRM) (FDEVOP (QUOTE CHARSETFN) (|fetch| (STREAM DEVICE) |of| STRM) STRM (\\\, NEWVALUE))) (\\\, STREAM)))) (PUTPROPS \\DECFILEPTR MACRO ((STREAM X) (\\INCFILEPTR STREAM (IMINUS X)))) (PUTPROPS \\GETFILEPTR MACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE GETFILEPTR) (|fetch| DEVICE |of| STRM) STRM))) (PUTPROPS \\SIGNEDWIN MACRO ((STREAM) (SIGNED (\\WIN STREAM) BITSPERWORD))) (PUTPROPS \\SIGNEDWOUT MACRO ((STREAM N) (\\WOUT STREAM (UNSIGNED N BITSPERWORD)))) (PUTPROPS \\WIN MACRO (OPENLAMBDA (STREAM) (|create| WORD HIBYTE _ (\\BIN STREAM) LOBYTE _ (\\BIN STREAM)))) (PUTPROPS \\WOUT MACRO (OPENLAMBDA (STREAM W) (\\BOUT STREAM (|fetch| HIBYTE |of| W)) (\\BOUT STREAM ( |fetch| LOBYTE |of| W)))) (PUTPROPS \\BINS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKIN) (|fetch| (STREAM DEVICE) |of| STRM) STRM BASE OFF NBYTES))) (PUTPROPS \\BOUTS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKOUT) (|fetch| ( STREAM DEVICE) |of| STRM) STRM BASE OFF NBYTES))) (PUTPROPS \\EOFP BYTEMACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE EOFP) (|fetch| (STREAM DEVICE) |of| STRM) STRM))) (PUTPROPS SIZE.FROM.LENGTH MACRO (LAMBDA (LEN) (DECLARE (LOCALVARS LEN)) (AND LEN (FOLDHI LEN BYTESPERPAGE)))) (RPAQQ |BitsPerByte| 8) (RPAQ |ByteOffsetSize| (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) (RPAQQ |WordsPerPage| 256) (CONSTANTS |BitsPerByte| (|ByteOffsetSize| (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) |WordsPerPage|) (RPAQ \\MAXFILEPTR (SUB1 (LLSH 1 30))) (CONSTANTS (\\MAXFILEPTR (SUB1 (LLSH 1 30)))) (ACCESSFNS BYTEPTR ((PAGE (FOLDLO DATUM BYTESPERPAGE)) (OFFSET (MOD DATUM BYTESPERPAGE))) (TYPE? (AND (FIXP DATUM) (IGEQ DATUM 0) (ILEQ DATUM \\MAXFILEPTR))) (CREATE (IPLUS (UNFOLD PAGE BYTESPERPAGE) OFFSET))) (PUTPROP (QUOTE FILEIO) (QUOTE IMPORTDATE) (IDATE "13-Aug-2020 11:43:08")) (BLOCKRECORD FIXP ((HINUM WORD) (LONUM WORD)) (CREATE (CREATECELL \\FIXP)) (TYPE? (EQ (NTYPX DATUM) \\FIXP))) (RPAQQ MAX.SMALL.INTEGER 65535) (RPAQQ MAX.POS.HINUM 32767) (CONSTANTS (MAX.SMALL.INTEGER 65535) (MAX.POS.HINUM 32767)) (PUTPROPS .UNBOX. MACRO (ARGS (LET ((ARG-FORM (CAR ARGS)) (HIGH-VAR (CADR ARGS)) (LOW-VAR (CADDR ARGS) ) (BIGNUM-FORM (CADDDR ARGS))) (BQUOTE (PROG NIL UBLP (SELECTC (NTYPX (\\\, ARG-FORM)) (\\FIXP (SETQ ( \\\, HIGH-VAR) (|ffetch| (FIXP HINUM) |of| (\\\, ARG-FORM))) (SETQ (\\\, LOW-VAR) (|ffetch| (FIXP LONUM) |of| (\\\, ARG-FORM)))) (\\SMALLP (COND ((ILEQ 0 (\\\, ARG-FORM)) (SETQ (\\\, HIGH-VAR) 0) ( SETQ (\\\, LOW-VAR) (\\\, ARG-FORM))) (T (SETQ (\\\, HIGH-VAR) 65535) (SETQ (\\\, LOW-VAR) (\\LOLOC ( \\\, ARG-FORM)))))) (\\FLOATP (SETQ (\\\, ARG-FORM) (\\FIXP.FROM.FLOATP (\\\, ARG-FORM))) (GO UBLP)) ( COND ((TYPENAMEP (\\\, ARG-FORM) (QUOTE RATIO)) (SETQ (\\\, ARG-FORM) (IQUOTIENT (CL::RATIO-NUMERATOR (\\\, ARG-FORM)) (CL::RATIO-DENOMINATOR (\\\, ARG-FORM)))) (GO UBLP)) (\\\,@ (COND (BIGNUM-FORM ( BQUOTE (((CL:INTEGERP (\\\, ARG-FORM)) (\\\, BIGNUM-FORM))))) (T (BQUOTE (((CL:INTEGERP (\\\, ARG-FORM )) (\\ILLEGAL.ARG (\\\, ARG-FORM)))))))) (T (CL::%NOT-NONCOMPLEX-NUMBER-ERROR (\\\, ARG-FORM)))))))))) (PUTPROPS .NEGATE. MACRO ((HY LY) (COND ((EQ 0 LY) (AND (NEQ HY 0) (SETQ HY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY))))) (T (SETQ HY (IDIFFERENCE MAX.SMALL.INTEGER HY)) (SETQ LY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY))))))) (PUTPROPS .LLSH1. MACRO ((HI LO) (* \; "shift the pair left one, assuming no overflow") (SETQ HI (LLSH HI 1)) (SETQ LO (LLSH (COND ((IGREATERP LO MAX.POS.HINUM) (|add| HI 1) (LOGAND LO MAX.POS.HINUM)) (T LO)) 1)))) (PUTPROPS .LRSH1. MACRO ((HI LO) (SETQ LO (LRSH LO 1)) (COND ((NEQ (LOGAND HI 1) 0) (SETQ LO (IPLUS LO \\SIGNBIT)))) (SETQ HI (LRSH HI 1)))) (PUTPROPS .BOXIPLUS. MACRO (OPENLAMBDA (X Y) (PROG ((HX (\\GETBASE X 0)) (LX (\\GETBASE X 1)) HY LY) ( .UNBOX. Y HY LY) (SETQ HX (COND ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY)) (IDIFFERENCE HX ( ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY)))) (T (IPLUS HX HY)))) (* |Add| |high| |parts|) (\\PUTBASE X 1 (COND ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY)) (* |Carry| |into| |high| |part.|) (SETQ HX ( COND ((EQ HX MAX.SMALL.INTEGER) 0) (T (ADD1 HX)))) (IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY)))) (T (IPLUS LX LY)))) (\\PUTBASE X 0 HX) (RETURN X)))) (PUTPROPS |PutUnboxed| DMACRO (= . \\PUTFIXP)) (PUTPROP (QUOTE LLARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 18:47:56")) (PUTPROPS POLYEVAL DMACRO ((X COEFFS DEGREE) (* \; "execute the POLYEVAL opcode on the value X, the array COEFFS with degree DEGREE") (\\FLOATBOX (( OPCODES UBFLOAT3 0) (\\FLOATUNBOX X) (|fetch| (ARRAYP BASE) |of| COEFFS) DEGREE)))) (BLOCKRECORD FLOATP ((SIGNBIT BITS 1) (EXPONENT BITS 8) (HIFRACTION BITS 7) (LOFRACTION BITS 16)) ( BLOCKRECORD FLOATP ((HIWORD WORD) (LOWORD WORD))) (BLOCKRECORD FLOATP ((NIL BITS 9) (LONGFRACTION BITS 23))) (BLOCKRECORD FLOATP ((FLOATCONTENTS BITS 32))) (BLOCKRECORD FLOATP ((NIL BITS 1) ( HIWORDNOSIGNBIT BITS 15))) (CREATE (\\FLOATBOX (\\VAG2 (LOGOR (LLSH SIGNBIT (PLUS 7 8)) (LLSH EXPONENT 7) HIFRACTION) LOFRACTION))) LOFRACTION _ 0 HIFRACTION _ 0 EXPONENT _ 0 SIGNBIT _ 0 (ACCESSFNS FLOATP ((EXP (LOGAND (LRSH (\\HILOC (\\FLOATUNBOX DATUM)) 7) 255)) (HIFRAC (LOGAND (\\HILOC (\\FLOATUNBOX DATUM)) 127))))) (RPAQQ MAX.DIGITS.ACCURACY 9) (CONSTANTS (MAX.DIGITS.ACCURACY 9)) (PUTPROPS \\CALLER.ARGS MACRO (X (LET ((ARGS (CAR X)) (FORMS (CDR X))) (BQUOTE (PROGN (\\SLOWRETURN) ( LET ((AL (\\MYALINK)) NEXT (\\\,@ (|for| VAR |in| ARGS |collect| (COND ((LISTP VAR) (LIST (CAR VAR) 0) ) (T VAR))))) (DECLARE (\\\,@ (|for| VAR |in| ARGS |when| (LISTP VAR) |collect| (BQUOTE (TYPE (\\\, ( SELECTQ (CADR VAR) ((FLOATING FLOATP) (CADR VAR)) (HELP))) (\\\, (CAR VAR))))))) (SETQ NEXT (|fetch| ( FX NEXTBLOCK) |of| AL)) (\\\,@ (|for| X |in| (REVERSE ARGS) |collect| (LET ((FORMS (BQUOTE ( \\.GETBASE32 \\STACKSPACE (SETQ NEXT (IDIFFERENCE NEXT WORDSPERCELL)))))) (COND ((LISTP X) (BQUOTE ( SETQ (\\\, (CAR X)) (\\FLOATBOX (\\\, FORMS))))) (T (BQUOTE (SETQ (\\\, X) (\\\, FORMS)))))))) ( \\MAKEFREEBLOCK NEXT (TIMES (\\\, (LENGTH ARGS)) WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| AL |with| NEXT) (PROGN (\\\,@ FORMS)))))))) (PUTPROP (QUOTE LLFLOAT) (QUOTE IMPORTDATE) (IDATE "16-May-1990 19:26:51")) (DEFOPTIMIZER FONTPROP (&REST ARGS) (SELECTQ (AND (EQ (CAADR ARGS) (QUOTE QUOTE)) (CADADR ARGS)) ( ASCENT (LIST (QUOTE FONTASCENT) (CAR ARGS))) (DESCENT (LIST (QUOTE FONTDESCENT) (CAR ARGS))) (HEIGHT ( LIST (QUOTE FONTHEIGHT) (CAR ARGS))) (QUOTE IGNOREMACRO))) (DATATYPE FONTCLASS ((PRETTYFONT# BYTE) DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME)) (DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) (FONTFAMILY POINTER) (FONTSIZE POINTER) (FONTFACE POINTER) (|\\SFAscent| WORD) (|\\SFDescent| WORD) (|\\SFHeight| WORD) (ROTATION WORD) (FBBOX SIGNEDWORD) (FBBOY SIGNEDWORD) (FBBDX SIGNEDWORD) (FBBDY SIGNEDWORD) (|\\SFLKerns| POINTER) ( |\\SFRWidths| POINTER) (FONTDEVICESPEC POINTER) (* \; "Holds the spec by which the font is known to the printing device, if coercion has been done") ( OTHERDEVICEFONTPROPS POINTER) (* \; "For individual devices to hang special information") (FONTSCALE POINTER) (\\SFFACECODE BITS 8) (FONTAVGCHARWIDTH WORD) (* \; "Set in FONTCREATE, used to fix up the linelength when DSPFONT is called") (FONTIMAGEWIDTHS POINTER) ( * \; "This is the image width, as opposed to the advanced width; initial hack for accents, kerning. Fields is referenced by FONTCREATE." ) (FONTCHARSETVECTOR POINTER) (* \; "A 256-pointer block, with one pointer per 'character set' --each group of 256 character codes. Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset." ) (FONTEXTRAFIELD2 POINTER)) FONTCHARSETVECTOR _ (\\CREATEFONTCHARSETVECTOR)) (RECORD FONTFACE (WEIGHT SLOPE EXPANSION) (ACCESSFNS ((COLOR (CDDDR DATUM) (RPLACD (CDDR DATUM) NEWVALUE)) (BACKCOLOR (COND ((CDDDR DATUM) (CAR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) ( RPLACD (CDDR DATUM) (LIST NIL NIL)))) (RPLACA (CDDDR DATUM) NEWVALUE))) (FORECOLOR (COND ((CDDDR DATUM ) (CADR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) (RPLACD (CDDR DATUM) (LIST NIL NIL)))) ( RPLACA (CDR (CDDDR DATUM)) NEWVALUE))))) WEIGHT _ (QUOTE MEDIUM) SLOPE _ (QUOTE REGULAR) EXPANSION _ ( QUOTE REGULAR) (TYPE? LISTP)) (DATATYPE CHARSETINFO (WIDTHS (* \; "The advance-width of each character, an array indexed by charcode. Usually the same as the imagewidth, but can differ for accents, kerns kerns. This is what should be used for stringwidth calculations." ) OFFSETS (* \; "Offset of each character into the image bitmap; X value of left edge") IMAGEWIDTHS ( * \; "imagewidths is not automagically allocated since it is not always needed") CHARSETBITMAP (* \; "Bitmap containing the character images, indexed by OFFSETS") YWIDTHS (CHARSETASCENT WORD) (* \; "Max ascent for all characters in this CHARSET") (CHARSETDESCENT WORD) (* \; "Max descent for all characters in this CHARSET") LEFTKERN) WIDTHS _ (\\CREATECSINFOELEMENT) OFFSETS _ (\\CREATECSINFOELEMENT)) (PUTPROPS FONTASCENT MACRO ((FONTSPEC) (|ffetch| |\\SFAscent| |of| (\\GETFONTDESC FONTSPEC)))) (PUTPROPS FONTDESCENT MACRO ((FONTSPEC) (|ffetch| |\\SFDescent| |of| (\\GETFONTDESC FONTSPEC)))) (PUTPROPS FONTHEIGHT MACRO ((FONTSPEC) (|ffetch| |\\SFHeight| |of| (\\GETFONTDESC FONTSPEC)))) (PUTPROPS \\FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) (\\GETBASE OFFSETSBLOCK CHAR8CODE))) (PUTPROPS \\FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET) (\\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET))) (PUTPROPS \\FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) (\\GETBASE WIDTHSBLOCK CHAR8CODE))) (PUTPROPS \\FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\\PUTBASE WIDTHSBLOCK INDEX WIDTH))) (PUTPROPS \\FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE) (\\FGETWIDTH (|ffetch| (CHARSETINFO WIDTHS) |of| (\\GETCHARSETINFO (\\CHARSET CHARCODE) FONTDESC)) (\\CHAR8CODE CHARCODE)))) (PUTPROPS \\FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) (\\FSETWIDTH (|ffetch| ( CHARSETINFO WIDTHS) |of| (\\GETCHARSETINFO (\\CHARSET CHARCODE) FONTDESC)) (\\CHAR8CODE CHARCODE) WIDTH))) (PUTPROPS \\FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE) (\\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE)) ) (PUTPROPS \\FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\\PUTBASE WIDTHSBLOCK INDEX WIDTH))) (PUTPROPS \\GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?) (* |;;| "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC. If NIL, then creates the required charset." ) (* |;;| "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") (OR (\\GETBASEPTR (|ffetch| FONTCHARSETVECTOR |of| FONTDESC) (UNFOLD CHARSET 2)) (\\CREATECHARSET CHARSET FONTDESC NOSLUG?)))) (PUTPROPS \\CREATECSINFOELEMENT MACRO (NIL (\\ALLOCBLOCK (FOLDHI (IPLUS \\MAXTHINCHAR 3) WORDSPERCELL) ))) (PUTPROPS \\CREATEFONTCHARSETVECTOR MACRO (NIL (* \; "Allocates a block for the character set records" ) (\\ALLOCBLOCK (ADD1 \\MAXCHARSET) T))) (DEFMACRO \\CREATEKERNELEMENT NIL (BQUOTE (CL:MAKE-ARRAY (IPLUS \\MAXTHINCHAR 3) :ELEMENT-TYPE (QUOTE (SIGNED-BYTE 16)) :INITIAL-ELEMENT 0))) (DEFMACRO \\FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE) (BQUOTE (CL:SETF (CL:AREF (\\\, LEFTKERNBLOCK ) (\\\, INDEX)) (\\\, KERNVALUE)))) (DEFMACRO \\FGETLEFTKERN (LEFTKERNBLOCK CHAR8CODE) (BQUOTE (CL:AREF (\\\, LEFTKERNBLOCK) (\\\, CHAR8CODE)))) (RPAQQ \\MAXNSCHAR 65535) (CONSTANTS (\\MAXNSCHAR 65535)) (PUTPROP (QUOTE FONT) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:29:49")) (BLOCKRECORD KEYACTION ((* |;;| "KEYACTION Table: For interpreting keystrokes. Stored as a 8-cell block of untyped pointer hunk storage." ) FLAGS (* \; "Flag byte per key# (one for down-transtion, 1 for up-.) to describe whether lockshifting occrrs, you ignore the transition, etc." ) CODES (* \; "Table of character codes generated by each key when no shift key is pressed.") SHIFTCODES (* \; "Table of character codes generated by each key when the shift key is pressed.") ARMED (* \; "Not sure...") INTERRUPTLIST (* \; "List of armed interrupts?") ALTGRAPHCODES (* \; "Table of codes to be generated when the ALT-GRAPH key is pressed.") DEADKEYLIST (* \; "Block of dead-key handlers, with the nominal up-transition fields filled by the shifted-case tables. Each \"table\" is an ALIST of orignal code => accented code. no entry means punt the accent.." )) FLAGS _ (\\ALLOCBLOCK (FOLDHI (IPLUS \\NKEYS \\NKEYS) BYTESPERCELL)) CODES _ (\\ALLOCBLOCK (FOLDHI (PLUS \\NKEYS \\NKEYS) WORDSPERCELL)) SHIFTCODES _ (\\ALLOCBLOCK (FOLDHI (PLUS \\NKEYS \\NKEYS) WORDSPERCELL)) ARMED _ (\\ALLOCBLOCK (FOLDHI (ADD1 \\MAXTHINCHAR) BITSPERCELL)) ALTGRAPHCODES _ ( \\ALLOCBLOCK (FOLDHI (PLUS \\NKEYS \\NKEYS) WORDSPERCELL)) DEADKEYLIST _ (\\ALLOCBLOCK (PLUS \\NKEYS \\NKEYS \\NKEYS \\NKEYS) T) (CREATE (\\ALLOCBLOCK 7 PTRBLOCK.GCT)) (TYPE? (AND (\\BLOCKDATAP DATUM) ( IGEQ (\\#BLOCKDATACELLS DATUM) 5) (OR (NULL (FETCH (KEYACTION INTERRUPTLIST) OF DATUM)) (LISTP (FETCH INTERRUPTLIST OF DATUM))) (\\BLOCKDATAP (FETCH (KEYACTION FLAGS) DATUM)) (\\BLOCKDATAP (FETCH ( KEYACTION CODES) DATUM)) (\\BLOCKDATAP (FETCH (KEYACTION ARMED) DATUM))))) (RPAQQ \\NKEYS 112) (CONSTANTS \\NKEYS) (DEFOPTIMIZER KEYDOWNP (KEYNAME) (BQUOTE (\\NEWKEYDOWNP (\\KEYNAMETONUMBER (\\\, KEYNAME))))) (PUTPROPS XKEYDOWNP MACRO ((KEYNAME) (KEYDOWNP1 (\\KEYNAMETONUMBER KEYNAME)))) (PUTPROPS KEYDOWNP1 MACRO (OPENLAMBDA (KEYNUMBER) (DECLARE (GLOBALVARS \\EM.KBDAD0 \\EM.KBDAD1 \\EM.KBDAD2 \\EM.KBDAD3 \\EM.UTILIN \\EM.KBDAD4 \\EM.KBDAD5)) (PROG NIL (RETURN (EQ 0 (LOGAND (LRSH ( LLSH 1 15) (PROGN (* (IMOD KEYNUMBER BITSPERWORD) - GETD |cause| IMOD |and| BITSPERWORD |not| |exported| |to| |user|) (LOGAND KEYNUMBER 15))) (\\GETBASE (SELECTQ (PROGN (* (FOLDLO KEYNUMBER BITSPERWORD) GETD |follows| |since| FOLDLO |and| BITSPERWORD |not| |exported| |to| |user|) (LRSH KEYNUMBER 4)) (0 \\EM.KBDAD0) (1 \\EM.KBDAD1) (2 \\EM.KBDAD2) (3 \\EM.KBDAD3) (4 \\EM.UTILIN) (5 (OR \\EM.KBDAD4 (RETURN))) (6 (OR \\EM.KBDAD5 (RETURN))) (RETURN)) 0))))))) (PUTPROPS \\NEWKEYDOWNP MACRO ((KEYNUMBER) (EQ 0 (\\GETBASEBIT \\LASTKEYSTATE KEYNUMBER)))) (GLOBALVARS \\KEYBOARD.DEVICE \\KEYBOARD.STREAM) (RPAQQ HARDCURSORHEIGHT 16) (RPAQQ HARDCURSORWIDTH 16) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD) (PUTPROPS \\SETMOUSEXY MACRO ((XPOS YPOS) (PROGN (SELECTC \\MACHINETYPE (\\DAYBREAK ( |\\DoveMisc.SetMousePosition| XPOS YPOS)) (\\MAIKO (SUBRCALL SETMOUSEXY XPOS YPOS)) (\\DANDELION (|do| (PROGN (|replace| (IOPAGE NEWMOUSEX) |of| \\IOPAGE |with| XPOS) (|replace| (IOPAGE NEWMOUSEY) |of| \\IOPAGE |with| YPOS)) |repeatuntil| (ILESSP (|fetch| (IOPAGE NEWMOUSESTATE) |of| \\IOPAGE) 32768)) (* \; "smash position until mouse says it is not busy") (|replace| (IOPAGE NEWMOUSEX) |of| \\IOPAGE |with| XPOS) (|replace| (IOPAGE NEWMOUSEY) |of| \\IOPAGE |with| YPOS) (|replace| (IOPAGE NEWMOUSESTATE ) |of| \\IOPAGE |with| 32768)) NIL) (PROGN (\\PUTBASE \\EM.MOUSEX 0 XPOS) (\\PUTBASE \\EM.MOUSEY 0 YPOS))))) (GLOBALVARS \\EM.MOUSEX \\EM.MOUSEY \\EM.CURSORX \\EM.CURSORY \\EM.UTILIN \\EM.REALUTILIN \\EM.KBDAD0 \\EM.KBDAD1 \\EM.KBDAD2 \\EM.KBDAD3 \\EM.KBDAD4 \\EM.KBDAD5 \\EM.DISPINTERRUPT \\EM.DISPLAYHEAD \\EM.CURSORBITMAP \\MACHINETYPE \\DEFAULTKEYACTION \\COMMANDKEYACTION \\CURRENTKEYACTION \\PERIODIC.INTERRUPT \\PERIODIC.INTERRUPT.FREQUENCY) (PUTPROP (QUOTE LLKEY) (QUOTE IMPORTDATE) (IDATE "19-May-2018 13:32:12")) (DATATYPE PILOTBBT ((PBTDESTLO WORD) (PBTDESTHI WORD) (PBTDESTBIT WORD) (PBTDESTBPL SIGNEDWORD) ( PBTSOURCELO WORD) (PBTSOURCEHI WORD) (PBTSOURCEBIT WORD) (PBTSOURCEBPL SIGNEDWORD) (PBTWIDTH WORD) ( PBTHEIGHT WORD) (PBTFLAGS WORD) (NIL 5 WORD)) (BLOCKRECORD PILOTBBT ((NIL 7 WORD) (NIL BITS 4) ( PBTGRAYOFFSET BITS 4) (PBTGRAYWIDTHLESSONE BITS 4) (PBTGRAYHEIGHTLESSONE BITS 4) (NIL 2 WORD) ( PBTBACKWARD FLAG) (PBTDISJOINT FLAG) (PBTDISJOINTITEMS FLAG) (PBTUSEGRAY FLAG) (PBTSOURCETYPE BITS 1) (PBTOPERATION BITS 2) (NIL BITS 9))) (ACCESSFNS PILOTBBT ((PBTSOURCE (\\VAG2 (|fetch| PBTSOURCEHI |of| DATUM) (|fetch| PBTSOURCELO |of| DATUM)) (PROGN (|replace| PBTSOURCEHI |of| DATUM |with| (\\HILOC NEWVALUE)) (|replace| PBTSOURCELO |of| DATUM |with| (\\LOLOC NEWVALUE)))) (PBTDEST (\\VAG2 (|fetch| PBTDESTHI |of| DATUM) (|fetch| PBTDESTLO |of| DATUM)) (PROGN (|replace| PBTDESTHI |of| DATUM |with| ( \\HILOC NEWVALUE)) (|replace| PBTDESTLO |of| DATUM |with| (\\LOLOC NEWVALUE)))))) (SYSTEM)) (DATATYPE \\DISPLAYDATA (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET |DDDestination| |DDClippingRegion| DDFONT |DDSlowPrintingCase| DDWIDTHSCACHE DDOFFSETSCACHE DDCOLOR DDLINEFEED |DDRightMargin| |DDLeftMargin| |DDScroll| DDOPERATION DDSOURCETYPE (|DDClippingLeft| WORD) ( |DDClippingRight| WORD) (|DDClippingBottom| WORD) (|DDClippingTop| WORD) (NIL WORD) (DDHELDFLG FLAG) ( XWINDOWHINT XPOINTER) (DDPILOTBBT POINTER) DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS DDEOLFN DDPAGEFULLFN |DDTexture| DDMICAXPOS DDMICAYPOS DDMICARIGHTMARGIN DDCHARSET (DDCHARSETASCENT WORD) (DDCHARSETDESCENT WORD) DDCHARHEIGHTDELTA (DDSPACEWIDTH WORD)) DDPILOTBBT _ (|create| PILOTBBT PBTDISJOINT _ T) |DDLeftMargin| _ 0 |DDRightMargin| _ SCREENWIDTH DDXPOSITION _ 0 DDYPOSITION _ 0 DDXOFFSET _ 0 DDYOFFSET _ 0 |DDClippingRegion| _ (|create| REGION) |DDDestination| _ |ScreenBitMap| DDXSCALE _ 1 DDYSCALE _ 1 |DDTexture| _ 0 (ACCESSFNS ((DDFOREGROUNDCOLOR (PROG ((VAL (|fetch| (\\DISPLAYDATA DDCOLOR) |of| DATUM))) (OR (FIXP VAL) (BITMAPP VAL) (AND (NULL VAL) 1) (CAR VAL) (MAXIMUMCOLOR ( BITSPERPIXEL (|fetch| (\\DISPLAYDATA |DDDestination|) |of| DATUM)))))) (DDBACKGROUNDCOLOR (OR (|fetch| (\\DISPLAYDATA |DDTexture|) |of| DATUM) 0)))) (SYSTEM)) (RECORD DISPLAYSTATE (ONOFF)) (RECORD DISPLAYINFO (DITYPE DIWIDTH DIHEIGHT DIBITSPERPIXEL DIWSOPS)) (PUTPROPS \\GETDISPLAYDATA MACRO (ARGS (COND ((CADR ARGS) (SUBPAIR (QUOTE (STRM STRMVAR)) ARGS (QUOTE (\\DTEST (|fetch| (STREAM IMAGEDATA) |of| (SETQ STRMVAR (\\OUTSTREAMARG STRM))) (QUOTE \\DISPLAYDATA)) ))) (T (SUBST (CAR ARGS) (QUOTE STRM) (QUOTE (\\DTEST (|fetch| (STREAM IMAGEDATA) |of| (\\OUTSTREAMARG STRM)) (QUOTE \\DISPLAYDATA)))))))) (PUTPROPS \\BITMASK MACRO ((N) (\\WORDELT BITMASKARRAY (LOGAND N 15)))) (PUTPROPS \\4BITMASK MACRO ((N) (\\WORDELT 4BITMASKARRAY (LOGAND N 3)))) (PUTPROPS \\NOTBITMASK MACRO ((N) (DECLARE (GLOBALVARS NOTBITMASKARRAY)) (\\WORDELT NOTBITMASKARRAY ( LOGAND N 15)))) (PUTPROPS \\NOT4BITMASK MACRO ((N) (\\WORDELT NOT4BITMASKARRAY (LOGAND N 3)))) (GLOBALVARS BITMASKARRAY NOTBITMASKARRAY 4BITMASKARRAY NOT4BITMASKARRAY) (RPAQQ WORDMASK 65535) (CONSTANTS (WORDMASK 65535)) (PUTPROPS \\INVALIDATEDISPLAYCACHE MACRO ((DISPLAYDATA) (* |This| |marks| |the| |character-printing| |caches| |of| |the| |displaystream| |as| |invalid.| |Needed| |when| |the| |font| |or| Y |position| |changes|) (|freplace| (\\DISPLAYDATA DDCHARSET) |of| DISPLAYDATA |with| MAX.SMALLP) (|freplace| ( \\DISPLAYDATA DDCHARSETASCENT) |of| DISPLAYDATA |with| MAX.SMALLP))) (PUTPROPS \\DSPGETCHARWIDTH MACRO ((CHARCODE DD) (\\FGETWIDTH (|ffetch| (\\DISPLAYDATA DDWIDTHSCACHE) |of| DD) CHARCODE))) (PUTPROPS \\DSPGETCHARIMAGEWIDTH MACRO ((CHARCODE DD) (\\FGETIMAGEWIDTH (|ffetch| (\\DISPLAYDATA DDCHARIMAGEWIDTHS) |of| DD) CHARCODE))) (PUTPROPS \\DSPGETCHAROFFSET MACRO ((CHARCODE DD) (\\GETBASE (|ffetch| (\\DISPLAYDATA DDOFFSETSCACHE) |of| DD) CHARCODE))) (PUTPROPS \\CONVERTOP MACRO ((OP) (* |rrb| "14-NOV-80 11:14") (* |Only| |for| |alto| |bitblt| !!) ( SELECTQ OP (|replace| 0 |of| NIL |with| NIL) (PAINT 1) (INVERT 2) (ERASE 3) 0))) (PUTPROPS |\\SFInvert| MACRO ((|BitMap| \y) (* |corrects| |for| |the| |fact| |that| |alto| |bitmaps| |are| |stored| |with| 0\,0 |as| |upper| |left| |while| |lisp| |bitmaps| |have| 0\,0 |as| |lower| |left.| |The| |correction| |is| |actually| |off| |by| |one| (|greater|) |because| \a |majority| |of| |the| |places| |that| |it| |is| |called| |actually| |need| |one| |more| |than| |corrected| Y |value.|) (IDIFFERENCE (|fetch| (BITMAP BITMAPHEIGHT) |of| |BitMap|) \y))) (PUTPROPS |\\SFReplicate| MACRO (LAMBDA (|pattern|) (LOGOR |pattern| (LLSH |pattern| 8) (SETQ |pattern| (LLSH |pattern| 4)) (LLSH |pattern| 8)))) (PUTPROPS \\SETPBTFUNCTION MACRO (OPENLAMBDA (BBT |SourceType| |Operation|) (PROGN (|replace| ( PILOTBBT PBTOPERATION) |of| BBT |with| (SELECTQ |Operation| (ERASE 1) (PAINT 2) (INVERT 3) 0)) ( |replace| (PILOTBBT PBTSOURCETYPE) |of| BBT |with| (COND ((EQ (EQ |SourceType| (QUOTE INVERT)) (EQ |Operation| (QUOTE ERASE))) 0) (T 1)))))) (PUTPROPS \\BITBLT1 MACRO ((|bbt|) (|BitBltSUBR| |bbt|))) (PUTPROP (QUOTE BITBLT) (QUOTE MACRO) (QUOTE (= . BKBITBLT))) (PROGN (PUTPROPS \\INSURETOPWDS DMACRO (OPENLAMBDA (DS) (OR (EQ DS \\TOPWDS) (COND ((FMEMB ( DSPDESTINATION NIL DS) \\SCREENBITMAPS) (\\TOTOPWDS DS)))))) (PUTPROPS \\INSURETOPWDS MACRO ((DS) (* |For| |non-window| |implementations|) (PROGN)))) (PUTPROPS .WHILE.TOP.DS. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* FIRST |should| |be| \a |displaystream| |and| \a |variable.| |This| |macro| |may| |also| |take| \a |soft| |cursor| |down,| |similar| |to| |the| |way| .WHILE.CURSOR.DOWN. |does,| |but| |only| |if| |FIRST's| |destination| |is| |the| |same| |as| |the| |soft| |cursor's| |destination.| *) (COND (\\SOFTCURSORP ( SETQ SOFTCURSORUP (AND \\SOFTCURSORUPP (EQ (DSPDESTINATION NIL FIRST) \\CURSORDESTINATION))) (COND ( SOFTCURSORUP (SETQ DISPINTERRUPT (\\GETBASE \\EM.DISPINTERRUPT 0)) (\\PUTBASE \\EM.DISPINTERRUPT 0 0) (\\SOFTCURSORDOWN))))) (\\INSURETOPWDS FIRST) (PROGN . REST) (COND (SOFTCURSORUP ( \\SOFTCURSORUPCURRENT) (\\PUTBASE \\EM.DISPINTERRUPT 0 DISPINTERRUPT)))))) (PUTPROPS .WHILE.CURSOR.DOWN. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* |This| |macro| |should| |wrap| |around| |any| |code| |that| |draws| |or| |bitblts| |directly| |from| |or| |to| \a |screen| |bitmap.| E.\g. DRAWGRAYBOX |in| HLDISPLAY |which| |puts| |up| \a |shadow| |box| |during| GETREGION. |The| |purpose| |of| |this| |macro| |is| |that| \a |soft| (|e.g.| |color|) |cursor's| |bits| |not| |be| |taken| |to| |be| |screen| |bits| |while| FIRST & REST |are| |done.| *) ( COND (\\SOFTCURSORP (SETQ SOFTCURSORUP \\SOFTCURSORUPP) (COND (SOFTCURSORUP (SETQ DISPINTERRUPT ( \\GETBASE \\EM.DISPINTERRUPT 0)) (\\PUTBASE \\EM.DISPINTERRUPT 0 0) (\\SOFTCURSORDOWN))))) (PROGN FIRST . REST) (COND (SOFTCURSORUP (\\SOFTCURSORUPCURRENT) (\\PUTBASE \\EM.DISPINTERRUPT 0 DISPINTERRUPT)))))) (ADDTOVAR GLOBALVARS \\TOPWDS) (DEFOPTIMIZER TTYDISPLAYSTREAM (&REST X) (COND ((NULL (CAR X)) (QUOTE \\TERM.OFD)) (T (QUOTE IGNOREMACRO)))) (GLOBALVARS BELLCNT BELLRATE TTYBACKGROUNDFNS |\\DisplayStoppedForLogout| \\CARET.UP) (PUTPROPS \\CHECKCARET MACRO ((X) (AND \\CARET.UP (\\CARET.DOWN X)))) (PUTPROPS \\DSPTRANSFORMX MACRO ((X DD) (* |transforms| |an| \x |coordinate| |into| |the| |destination| |coordinate.|) (IPLUS X (|fetch| (\\DISPLAYDATA DDXOFFSET) |of| DD)))) (PUTPROPS \\DSPTRANSFORMY MACRO ((Y DD) (* |transforms| |an| \y |coordinate| |into| |the| |destination| |coordinate.|) (IPLUS Y (|fetch| (\\DISPLAYDATA DDYOFFSET) |of| DD)))) (PUTPROPS \\OFFSETBOTTOM MACRO ((X) (* |gives| |the| |destination| |coordinate| |address| |of| |the| |origin.|) (|fetch| (\\DISPLAYDATA DDYOFFSET) |of| X))) (PUTPROPS \\OFFSETLEFT MACRO ((DD) (* |returns| |the| \x |origin| |of| |display| |data| |destination| |coordinates.|) (|fetch| (\\DISPLAYDATA DDXOFFSET) |of| DD))) (PUTPROPS DISPLAYINITIALIZEDP MACRO (NIL (* |always| |initialized| |now|) T)) (PUTPROPS DISPLAYSTARTEDP MACRO (NIL |\\DisplayStarted|)) (GLOBALVARS |\\DisplayStarted| |\\DisplayStreamsInitialized| |\\DisplayInitialed| WHOLEDISPLAY WHOLESCREEN SCREENWIDTH SCREENHEIGHT) (PUTPROP (QUOTE LLDISPLAY) (QUOTE IMPORTDATE) (IDATE "18-Apr-1994 00:20:42")) (RECORD REGION (LEFT BOTTOM WIDTH HEIGHT) LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767 ( ACCESSFNS ((TOP (IPLUS (|fetch| (REGION BOTTOM) |of| DATUM) (|fetch| (REGION HEIGHT) |of| DATUM) -1)) (PTOP (IPLUS (|fetch| (REGION BOTTOM) |of| DATUM) (|fetch| (REGION HEIGHT) |of| DATUM))) (RIGHT (IPLUS (|fetch| (REGION LEFT) |of| DATUM) (|fetch| (REGION WIDTH) |of| DATUM) -1)) (PRIGHT (IPLUS (|fetch| ( REGION LEFT) |of| DATUM) (|fetch| (REGION WIDTH) |of| DATUM))))) (TYPE? (AND (EQLENGTH DATUM 4) (EVERY DATUM (FUNCTION NUMBERP)))) (SYSTEM)) (DATATYPE BITMAP ((BITMAPBASE POINTER) (BITMAPRASTERWIDTH WORD) (BITMAPHEIGHT WORD) (BITMAPWIDTH WORD) (BITMAPBITSPERPIXEL WORD)) BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((|BitMapHiLoc| WORD) ( |BitMapLoLoc| WORD)) (* \; "overlay initial pointer")) (SYSTEM)) (BLOCKRECORD BITMAPWORD ((BITS WORD)) (SYSTEM)) (RECORD POSITION (XCOORD . YCOORD) (TYPE? (AND (LISTP DATUM) (NUMBERP (CAR DATUM)) (NUMBERP (CDR DATUM )))) (SYSTEM)) (DATATYPE CURSOR (CUIMAGE CUMASK CUHOTSPOTX CUHOTSPOTY CUDATA) (ACCESSFNS ((CUBITSPERPIXEL (|fetch| ( BITMAP BITMAPBITSPERPIXEL) |of| (|fetch| (CURSOR CUIMAGE) |of| DATUM))))) (SYSTEM)) (RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME) (SYSTEM)) (RECORD SCREENREGION (SCREEN . REGION) (SUBRECORD REGION) (TYPE? (AND (LISTP DATUM) (|type?| SCREEN ( CAR DATUM)) (|type?| REGION (CDR DATUM)))) (SYSTEM)) (RECORD SCREENPOSITION (SCREEN . POSITION) (SUBRECORD POSITION) (TYPE? (AND (LISTP DATUM) (|type?| SCREEN (CAR DATUM)) (|type?| POSITION (CDR DATUM)))) (SYSTEM)) (PUTPROPS CURSORBITMAP MACRO (NIL |CursorBitMap|)) (RPAQQ HARDCURSORHEIGHT 16) (RPAQQ HARDCURSORWIDTH 16) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (ADDTOVAR GLOBALVARS |CursorBitMap|) (ARRAYRECORD POLYNOMIAL (A B C D) (CREATE (ARRAY 4 (QUOTE FLOATP))) (SYSTEM)) (RECORD SPLINE (\#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY)) (PUTPROPS HALF MACRO ((X) (LRSH X 1))) (PUTPROPS \\FILLCIRCLEBLT MACRO (OPENLAMBDA (CX CY X Y) (* \; "calls bitblt twice to fill in one line of the circle.") (\\LINEBLT FCBBT (IDIFFERENCE CX X) (IPLUS CY Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS ) (\\LINEBLT FCBBT (IDIFFERENCE CX X) (IDIFFERENCE CY Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS))) (PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (VARS . X)))))) (PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (E (MAPC (QUOTE X) (QUOTE PRINTCURSOR)))))))) (ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH |ScreenBitMap|) (RPAQQ BLACKSHADE 65535) (RPAQQ WHITESHADE 0) (CONSTANTS (BLACKSHADE 65535) (WHITESHADE 0)) (RPAQQ GRAYSHADE 43605) (ADDTOVAR GLOBALVARS GRAYSHADE) (RECORD HLS (HUE LIGHTNESS SATURATION)) (RECORD RGB (RED GREEN BLUE)) (PUTPROP (QUOTE ADISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Sep-1994 17:07:04")) (ADDTOVAR SYSSPECVARS \\INTERRUPTABLE) (PUTPROPS UNINTERRUPTABLY INFO EVAL) (PUTPROPS UNINTERRUPTABLY DMACRO ((X . Y) ((LAMBDA (\\INTERRUPTABLE) (PROGN X . Y)) NIL))) (ADDTOVAR PRETTYPRINTMACROS (UNINTERRUPTABLY LAMBDA (FORM) (PROG ((POS (IPLUS 4 (POSITION)))) (PRIN1 "(") (PRIN2 (CAR FORM)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM (CDR FORM)))) (TAB POS 0)) (PRINTDEF FORM POS T T FNSLST) (PRIN1 ")")))) (BLOCKRECORD INTERRUPTSTATE ((* |;;| "This is the structure used to communicate between the emulator and Lisp re interrupts. There is a bit per interrupt type, plus space for the character code that caused a keyboard interrupt." ) (* |;;| "This must match the INTSTAT definition in lispemul.h") (* |;;| "PENDING-INTERRUPT FLAGS:") (LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.") (ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.") (IOINTERRUPT FLAG) (GCDISABLED FLAG) (* \; "No mroe room in GC tables." ) (VMEMFULL FLAG) (* \; "VMEM is full!!") (STACKOVERFLOW FLAG) (* \; "Stack overflowed.") (STORAGEFULL FLAG) (* \; "Ran out of storage, atoms, etc.") (WAITINGINTERRUPT FLAG) (* |;;| "INTERRUPTS-IN-PROCESS MASK:") (P-LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.") ( P-ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.") (P-IOINTERRUPT FLAG) (P-GCDISABLED FLAG) ( * \; "No mroe room in GC tables.") (P-VMEMFULL FLAG) (* \; "VMEM is full!!") (P-STACKOVERFLOW FLAG) (* \; "Stack overflowed.") (P-STORAGEFULL FLAG) (* \; "Ran out of storage, atoms, etc.") ( P-WAITINGINTERRUPT FLAG) (INTCHARCODE WORD)) (BLOCKRECORD INTERRUPTSTATE ((* |;;| "Alternative view of the structure:") (PENDING BITS 8) (* \; "Pending-interrupt flags") (IN-PROGRESS BITS 8) (* \; "Mask to prevent re-interrupt for an interrupt in progress") (NIL WORD)))) (PUTPROPS \\TAKEINTERRUPT DMACRO ((PREFORM POSTFORM) (DECLARE (GLOBALVARS \\PENDINGINTERRUPT)) (COND ( (AND \\PENDINGINTERRUPT (INTERRUPTABLE~=NILUPTHESTACK)) PREFORM ((LAMBDA (\\INTERRUPTABLE) ( \\CALLINTERRUPTED)) T) POSTFORM)))) (PUTPROP (QUOTE AINTERRUPT) (QUOTE IMPORTDATE) (IDATE "17-Sep-1992 10:42:38")) (ACCESSFNS PUP ((PUPBASE (LOCF (|fetch| (ETHERPACKET EPBODY) |of| DATUM)))) (BLOCKRECORD PUPBASE (( PUPLENGTH WORD) (PUPTCONTROL BYTE) (PUPTYPE BYTE) (PUPID FIXP) (PUPDEST WORD) (PUPDESTSOCKET FIXP) ( PUPSOURCE WORD) (PUPSOURCESOCKET FIXP) (PUPDATASTART 266 WORD)) (BLOCKRECORD PUPBASE ((NIL WORD) ( TYPEWORD WORD) (PUPIDHI WORD) (PUPIDLO WORD) (PUPDESTNET BYTE) (PUPDESTHOST BYTE) (PUPDESTSOCKETHI WORD) (PUPDESTSOCKETLO WORD) (PUPSOURCENET BYTE) (PUPSOURCEHOST BYTE) (PUPSOURCESOCKETHI WORD) ( PUPSOURCESOCKETLO WORD)) (* \; "Temporary extra synonyms") (SYNONYM PUPDESTNET (DESTNET)) (SYNONYM PUPDESTHOST (DESTHOST)) (SYNONYM PUPDESTSOCKETHI (DESTSKTHI)) (SYNONYM PUPDESTSOCKETLO (DESTSKTLO)) ( SYNONYM PUPSOURCENET (SOURCENET)) (SYNONYM PUPSOURCEHOST (SOURCEHOST)) (SYNONYM PUPSOURCESOCKETHI ( SOURCESKTHI)) (SYNONYM PUPSOURCESOCKETLO (SOURCESKTLO))) (SYNONYM PUPDEST (DEST)) (SYNONYM PUPDESTSOCKET (DESTSKT)) (SYNONYM PUPSOURCE (SOURCE)) (SYNONYM PUPSOURCESOCKET (SOURCESKT)) (ACCESSFNS PUPDATASTART ((PUPCONTENTS (LOCF DATUM))))) (ACCESSFNS PUP ((PUPCHECKSUMBASE (|fetch| PUPBASE |of| DATUM)) (PUPCHECKSUMLOC (\\ADDBASE (|fetch| PUPBASE |of| DATUM) (FOLDLO (SUB1 (|fetch| PUPLENGTH |of| DATUM)) BYTESPERWORD)))) (BLOCKRECORD PUPCHECKSUMLOC ((PUPCHECKSUM WORD)))) (TYPE? (|type?| ETHERPACKET DATUM))) (ACCESSFNS PUPADDRESS ((PUPNET# (LRSH DATUM 8)) (PUPHOST# (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH PUPNET# 8) PUPHOST#))) (PUTPROPS \\LOCALPUPADDRESS MACRO (NIL \\LOCALPUPNETHOST)) (PUTPROPS \\LOCALPUPHOSTNUMBER MACRO (NIL (|fetch| PUPHOST# |of| \\LOCALPUPNETHOST))) (PUTPROPS \\LOCALPUPNETNUMBER MACRO (NIL (|fetch| PUPNET# |of| \\LOCALPUPNETHOST))) (ACCESSFNS ERRORPUP ((ERRORPUPBASE (|fetch| PUPCONTENTS |of| DATUM))) (BLOCKRECORD ERRORPUPBASE (( ERRORPUPCOPY 10 WORD) (* \; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* \; "Usually zero") (ERRORPUPSTRINGBASE WORD) (* \; "Human readable message")))) (RPAQQ PUPERRORCODES ((\\PUPE.CHECKSUM 1) (\\PUPE.NOSOCKET 2) (\\PUPE.SOCKETFULL 3) ( \\PUPE.GATEWAY.BADPUP 513) (\\PUPE.NOROUTE 514) (\\PUPE.NOHOST 515) (\\PUPE.LOOPED 516) ( \\PUPE.TOOLARGE 517) (\\PUPE.WRONG.GATEWAY 518) (\\PUPE.GATEWAYFULL 519))) (RPAQQ \\PUPE.CHECKSUM 1) (RPAQQ \\PUPE.NOSOCKET 2) (RPAQQ \\PUPE.SOCKETFULL 3) (RPAQQ \\PUPE.GATEWAY.BADPUP 513) (RPAQQ \\PUPE.NOROUTE 514) (RPAQQ \\PUPE.NOHOST 515) (RPAQQ \\PUPE.LOOPED 516) (RPAQQ \\PUPE.TOOLARGE 517) (RPAQQ \\PUPE.WRONG.GATEWAY 518) (RPAQQ \\PUPE.GATEWAYFULL 519) (CONSTANTS (\\PUPE.CHECKSUM 1) (\\PUPE.NOSOCKET 2) (\\PUPE.SOCKETFULL 3) (\\PUPE.GATEWAY.BADPUP 513) ( \\PUPE.NOROUTE 514) (\\PUPE.NOHOST 515) (\\PUPE.LOOPED 516) (\\PUPE.TOOLARGE 517) ( \\PUPE.WRONG.GATEWAY 518) (\\PUPE.GATEWAYFULL 519)) (PUTPROPS BINDPUPS MACRO (X (CONS (LIST (QUOTE LAMBDA) (CAR X) (CONS (QUOTE PROGN) (CDR X))) (|in| ( CAR X) |collect| (LIST (QUOTE ALLOCATE.PUP)))))) (PUTPROPS BINDPUPS INFO BINDS) (ADDTOVAR PRETTYPRINTMACROS (BINDPUPS LAMBDA (FORM) (PROG ((POS (IPLUS 2 (POSITION)))) (PRIN1 "(") ( PRIN2 (CAR FORM)) (SPACES 1) (PRINTDEF (CADR FORM) (POSITION)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM ( CDDR FORM)))) (TAB POS 0)) (PRINTDEF FORM POS T T FNSLST) (PRIN1 ")")))) (BLOCKRECORD PORT ((NETHOST WORD) (SOCKET FIXP)) (BLOCKRECORD PORT ((NET BYTE) (HOST BYTE) (SOCKETHI WORD) (SOCKETLO WORD)))) (ACCESSFNS ERRORPUP ((ERRORPUPBASE (|fetch| PUPCONTENTS |of| DATUM))) (BLOCKRECORD ERRORPUPBASE (( ERRORPUPCOPY 10 WORD) (* \; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* \; "Usually zero") (ERRORPUPSTRINGBASE WORD) (* \; "Human readable message")))) (GLOBALVARS \\ETHERWAIT1 \\ETHERTIMEOUT \\MAXETHERTRIES PUPTRACEFLG LOGINPASSWORDS) (GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS) (RPAQQ \\PUPOVLEN 22) (RPAQQ \\MAX.PUPLENGTH 532) (RPAQQ \\TIME.GETPUP 5) (CONSTANTS (\\PUPOVLEN 22) (\\MAX.PUPLENGTH 532) (\\TIME.GETPUP 5)) (PUTPROPS PUPPRINTMACROS VARTYPE ALIST) (PUTPROPS \\GETPUPWORD DMACRO ((PUP WORD#) (\\GETBASE (|fetch| PUPCONTENTS |of| PUP) WORD#))) (PUTPROPS \\PUTPUPWORD DMACRO ((PUP WORD# VALUE) (\\PUTBASE (|fetch| PUPCONTENTS |of| PUP) WORD# VALUE ))) (PUTPROPS \\GETPUPBYTE DMACRO ((PUP BYTE#) (\\GETBASEBYTE (|fetch| PUPCONTENTS |of| PUP) BYTE#))) (PUTPROPS \\PUTPUPBYTE DMACRO ((PUP BYTE# VALUE) (\\PUTBASEBYTE (|fetch| PUPCONTENTS |of| PUP) BYTE# VALUE))) (RPAQQ RAWPUPTYPES ((\\PT.ECHOME 1) (\\PT.IAMECHO 2) (\\PT.IAMBADECHO 3) (\\PT.ERROR 4) (\\PT.RFC 8) ( \\PT.ABORT 9) (\\PT.END 10) (\\PT.ENDREPLY 11) (\\PT.DATA 16) (\\PT.ADATA 17) (\\PT.ACK 18) (\\PT.MARK 19) (\\PT.INTERRUPT 20) (\\PT.INTERRUPTREPLY 21) (\\PT.AMARK 22) (\\PT.GATEWAYREQUEST 128) ( \\PT.GATEWAYRESPONSE 129) (\\PT.ALTOTIMEREQUEST 134) (\\PT.ALTOTIMERESPONSE 135) (\\PT.MSGCHECK 136) ( \\PT.NEWMAIL 137) (\\PT.NONEWMAIL 138) (\\PT.NOMAILBOX 139) (\\PT.LAURELCHECK 140) (\\PT.NAMELOOKUP 144) (\\PT.NAMERESPONSE 145) (\\PT.NAME/ADDRERROR 146) (\\PT.ADDRLOOKUP 147) (\\PT.ADDRRESPONSE 148) ( \\PT.PRINTERSTATUS 128) (\\PT.STATUSRESPONSE 129) (\\PT.PRINTERCAPABILITY 130) ( \\PT.CAPABILITYRESPONSE 131) (\\PT.PRINTJOBSTATUS 132) (\\PT.PRINTJOBRESPONSE 133))) (RPAQQ \\PT.ECHOME 1) (RPAQQ \\PT.IAMECHO 2) (RPAQQ \\PT.IAMBADECHO 3) (RPAQQ \\PT.ERROR 4) (RPAQQ \\PT.RFC 8) (RPAQQ \\PT.ABORT 9) (RPAQQ \\PT.END 10) (RPAQQ \\PT.ENDREPLY 11) (RPAQQ \\PT.DATA 16) (RPAQQ \\PT.ADATA 17) (RPAQQ \\PT.ACK 18) (RPAQQ \\PT.MARK 19) (RPAQQ \\PT.INTERRUPT 20) (RPAQQ \\PT.INTERRUPTREPLY 21) (RPAQQ \\PT.AMARK 22) (RPAQQ \\PT.GATEWAYREQUEST 128) (RPAQQ \\PT.GATEWAYRESPONSE 129) (RPAQQ \\PT.ALTOTIMEREQUEST 134) (RPAQQ \\PT.ALTOTIMERESPONSE 135) (RPAQQ \\PT.MSGCHECK 136) (RPAQQ \\PT.NEWMAIL 137) (RPAQQ \\PT.NONEWMAIL 138) (RPAQQ \\PT.NOMAILBOX 139) (RPAQQ \\PT.LAURELCHECK 140) (RPAQQ \\PT.NAMELOOKUP 144) (RPAQQ \\PT.NAMERESPONSE 145) (RPAQQ \\PT.NAME/ADDRERROR 146) (RPAQQ \\PT.ADDRLOOKUP 147) (RPAQQ \\PT.ADDRRESPONSE 148) (RPAQQ \\PT.PRINTERSTATUS 128) (RPAQQ \\PT.STATUSRESPONSE 129) (RPAQQ \\PT.PRINTERCAPABILITY 130) (RPAQQ \\PT.CAPABILITYRESPONSE 131) (RPAQQ \\PT.PRINTJOBSTATUS 132) (RPAQQ \\PT.PRINTJOBRESPONSE 133) (CONSTANTS (\\PT.ECHOME 1) (\\PT.IAMECHO 2) (\\PT.IAMBADECHO 3) (\\PT.ERROR 4) (\\PT.RFC 8) ( \\PT.ABORT 9) (\\PT.END 10) (\\PT.ENDREPLY 11) (\\PT.DATA 16) (\\PT.ADATA 17) (\\PT.ACK 18) (\\PT.MARK 19) (\\PT.INTERRUPT 20) (\\PT.INTERRUPTREPLY 21) (\\PT.AMARK 22) (\\PT.GATEWAYREQUEST 128) ( \\PT.GATEWAYRESPONSE 129) (\\PT.ALTOTIMEREQUEST 134) (\\PT.ALTOTIMERESPONSE 135) (\\PT.MSGCHECK 136) ( \\PT.NEWMAIL 137) (\\PT.NONEWMAIL 138) (\\PT.NOMAILBOX 139) (\\PT.LAURELCHECK 140) (\\PT.NAMELOOKUP 144) (\\PT.NAMERESPONSE 145) (\\PT.NAME/ADDRERROR 146) (\\PT.ADDRLOOKUP 147) (\\PT.ADDRRESPONSE 148) ( \\PT.PRINTERSTATUS 128) (\\PT.STATUSRESPONSE 129) (\\PT.PRINTERCAPABILITY 130) ( \\PT.CAPABILITYRESPONSE 131) (\\PT.PRINTJOBSTATUS 132) (\\PT.PRINTJOBRESPONSE 133)) (RPAQ? PUPTYPES RAWPUPTYPES) (RPAQQ WELLKNOWNPUPSOCKETS ((\\PUPSOCKET.TELNET 1) (\\PUPSOCKET.ROUTING 2) (\\PUPSOCKET.FTP 3) ( \\PUPSOCKET.MISCSERVICES 4) (\\PUPSOCKET.ECHO 5) (\\PUPSOCKET.EFTP 16) (\\PUPSOCKET.PRINTERSTATUS 17) (\\PUPSOCKET.LEAF 35))) (RPAQQ \\PUPSOCKET.TELNET 1) (RPAQQ \\PUPSOCKET.ROUTING 2) (RPAQQ \\PUPSOCKET.FTP 3) (RPAQQ \\PUPSOCKET.MISCSERVICES 4) (RPAQQ \\PUPSOCKET.ECHO 5) (RPAQQ \\PUPSOCKET.EFTP 16) (RPAQQ \\PUPSOCKET.PRINTERSTATUS 17) (RPAQQ \\PUPSOCKET.LEAF 35) (CONSTANTS (\\PUPSOCKET.TELNET 1) (\\PUPSOCKET.ROUTING 2) (\\PUPSOCKET.FTP 3) ( \\PUPSOCKET.MISCSERVICES 4) (\\PUPSOCKET.ECHO 5) (\\PUPSOCKET.EFTP 16) (\\PUPSOCKET.PRINTERSTATUS 17) (\\PUPSOCKET.LEAF 35)) (PUTPROP (QUOTE PUP) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 11:14:09")) (PUTPROPS UNLESSRDSYS MACRO ((NORMAL RDSYS) NORMAL)) (PUTPROPS UNLESSINEW MACRO ((NORMAL I-NEW) NORMAL)) (PUTPROPS 1ST MACRO ((A . B) A)) (PUTPROPS 2ND MACRO ((A B . C) B)) (PUTPROPS LOCAL MACRO ((X) X)) (PUTPROPS ALLOCAL MACRO ((X) X)) (PUTPROPS ADDBASE DMACRO (= . \\ADDBASE)) (PUTPROPS GETBASE DMACRO (= . \\GETBASE)) (PUTPROPS GETBASEBYTE DMACRO (= . \\GETBASEBYTE)) (PUTPROPS GETBASEPTR DMACRO (= . \\GETBASEPTR)) (PUTPROPS HILOC DMACRO (= . \\HILOC)) (PUTPROPS LOLOC DMACRO (= . \\LOLOC)) (PUTPROPS PUTBASE DMACRO (= . \\PUTBASE)) (PUTPROPS PUTBASEBYTE DMACRO (= . \\PUTBASEBYTE)) (PUTPROPS PUTBASEPTR DMACRO (= . \\PUTBASEPTR)) (PUTPROPS REPLACEPTRFIELD DMACRO (= . \\RPLPTR)) (PUTPROPS VAG2 DMACRO (= . \\VAG2)) (PUTPROPS PAGEBASE MACRO ((PTR) (|fetch| (POINTER PAGEBASE) |of| PTR))) (PUTPROPS PAGELOC MACRO (OPENLAMBDA (PTR) (IPLUS (LLSH (\\HILOC PTR) 8) (LRSH (\\LOLOC PTR) 8)))) (PUTPROP (QUOTE RENAMEMACROS) (QUOTE IMPORTDATE) (IDATE "27-Apr-1994 15:43:27")) (PUTPROPS MOUSESTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR ARGS) T)))) (PUTPROPS LASTMOUSESTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS) T))) (PUTPROPS UNTILMOUSESTATE MACRO (ARGS (COND ((AND (CDR ARGS) (CADR ARGS) (NEQ (CADR ARGS) T)) (* |time| |argument| |is| |given| |and| |is| |not| T |or| NIL\; |compile| |in| |time| |keeping| |loop.|) (LIST (QUOTE PROG) (LIST (LIST (QUOTE TIMEOUT) (LIST (QUOTE IPLUS) (QUOTE (CLOCK 0)) (LIST (QUOTE OR) (LIST (QUOTE NUMBERP) (CADR ARGS)) 100))) (QUOTE (NOWTIME (CLOCK 0)))) (QUOTE LP) (LIST (QUOTE COND) ( LIST (CONS (QUOTE MOUSESTATE) (LIST (CAR ARGS) T)) (QUOTE (RETURN T)))) (QUOTE (COND ((IGREATERP ( CLOCK0 NOWTIME) TIMEOUT) (RETURN NIL)) (T (\\BACKGROUND)))) (QUOTE (GO LP)))) (T (LIST (QUOTE PROG) NIL (QUOTE LP) (LIST (QUOTE COND) (LIST (CONS (QUOTE MOUSESTATE) (LIST (CAR ARGS) T)) (QUOTE (RETURN T )))) (QUOTE (\\BACKGROUND)) (QUOTE (GO LP))))))) (PUTPROPS KEYSETSTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR ARGS))))) (PUTPROPS LASTKEYSETSTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS)))) (PUTPROPS WITHIN MACRO ((A B C) (AND (IGEQ A B) (ILESSP A (IPLUS B C))))) (ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS) (PUTPROPS IABS MACRO (OPENLAMBDA (A) (COND ((IGEQ A 0) A) (T (IMINUS A))))) (PUTPROP (QUOTE HLDISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Mar-1994 10:48:02")) (PUTPROPS .COPYKEYDOWNP. MACRO (NIL (OR (KEYDOWNP (QUOTE LSHIFT)) (KEYDOWNP (QUOTE RSHIFT)) (KEYDOWNP (QUOTE COPY))))) (PUTPROPS WSOP MACRO (ARGS (LET ((METHOD (CADR (CAR ARGS))) (DISPLAY (CADR ARGS)) (OTHERARGS (CDDR ARGS))) (BQUOTE (SPREADAPPLY* (|fetch| (WSOPS (\\\, METHOD)) |of| (|fetch| (FDEV WINDOWOPS) |of| (\\\, DISPLAY))) (\\\, DISPLAY) (\\\,@ OTHERARGS)))))) (PUTPROPS \\COERCETODS MACRO (OPENLAMBDA (X) (COND ((|type?| WINDOW X) (|fetch| (WINDOW DSP) |of| X)) (T (\\ILLEGAL.ARG X))))) (PUTPROPS .WHILE.ON.TOP. MACRO ((FIRST . REST) (UNINTERRUPTABLY (\\INTERNALTOTOPW FIRST) . REST))) (PUTPROPS WINDOWOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS ))) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (|fetch| (SCREEN (\\\, (CADR OPNAME))) |of| (\\\, METHOD-DEVICE)) (\\\, METHOD-DEVICE) (\\\,@ TAIL)))) (T (ERROR "OPNAME not quoted: " OPNAME)))))) (RPAQQ |MinWindowWidth| 26) (RPAQQ |MinWindowHeight| 16) (CONSTANTS (|MinWindowWidth| 26) (|MinWindowHeight| 16)) (DATATYPE WINDOW (DSP (* \; "The display stream you use to actually printto the window.") NEXTW (* \; "Next window in the open-window list") SAVE (* \; "Saved image from anything this window's on top of") REG (* \; "Screen region this window occupies") BUTTONEVENTFN (* \; "FN called when left/middle mouse button goes up/down") RIGHTBUTTONFN (* \; "FN called when right mouse button goes up/down") CURSORINFN (* \; "Fn called when mouse enters window") CURSOROUTFN (* \; "Called when mouse leaves window") CURSORMOVEDFN (* \; "Called when mouse moves in window") REPAINTFN (* \; "Redisplay part of thie window") RESHAPEFN (* \; "Called when window is reshaped") EXTENT (* \; "Scrolling limits") USERDATA (* \; "Proplist to hold other window properites") VERTSCROLLREG (* \; "Region of vert scroll bar") HORIZSCROLLREG (* \; "Tegion of horiz scroll bar") SCROLLFN (* \; "Fn to scroll this window") VERTSCROLLWINDOW (* \; "Vert scroll bar") HORIZSCROLLWINDOW (* \; "Horiz scroll bar") CLOSEFN (* \; "Called at close time") MOVEFN (* \; "Called when window is moved") WTITLE (* \; "Window's title string, if any") NEWREGIONFN (* \; "Called to get new window shape") WBORDER (* \; "Window border-width, in pixels") PROCESS (* \; "Medley process associated with this window") WINDOWENTRYFN (* \; "Fn to call when kbd focus is switched here") SCREEN (* \; "Screen this window appears on") ( NATIVE-HANDLE FIXP) (* \; "Uniterpreted place for native window to store a C pointer to its private info") (NATIVE-INFO1 FIXP) ( * \; "Reserved in case the pointer must be 64 bits") (NATIVE-W1 WORD) (* \; "Word for use by native handler") (NATIVE-W2 WORD) (* \; "Word for use by native handler") (NATIVE-P1 POINTER) (* \; "Lisp pointer for use by native handler")) BUTTONEVENTFN _ (FUNCTION TOTOPW) WBORDER _ |WBorder| WINDOWENTRYFN _ (FUNCTION GIVE.TTY.PROCESS) (SYSTEM)) (DATATYPE SCREEN (SCONOFF SCDESTINATION SCWIDTH SCHEIGHT SCTOPW SCTOPWDS SCTITLEDS SCFDEV SCDS SCDATA (* |;;| "Space for native window manager interface to use.") (HANDLE FIXP) (* \; "Handle for emulator to store info about display for C code use.") (HANDLE2 FIXP) (* \; "Reserved in case HANDLE needs to be 64 bits on the C side.") (NATIVE-INFO POINTER) (* \; "POINTER for the private use of the emulator window code") NATIVETYPE (* \; "Symbol to tell what kind of native window system we're using.") (* |;;| "- - - Functional interface to screen management - - -") WINIMAGEOPS (* \; "IMAGEOPS to be used in display streas on this kind of screen") WINFDEV (* \; "FDEV for display streams on this screen") CREATEWFN (* \; "Create a window") OPENWFN (* \; "Open a window") CLOSEWFN (* \; "Close a window") MOVEWFN (* \; "Move a window") RELMOVEWFN (* \; "Move window, relative") SHRINKWFN (* \; "Shrink window to icon") EXPANDWFN (* \; "Expand icon to window") SHAPEWFN (* \; "Reshape a window") REDISPLAYFN (* \; "Redisplay (part of) a window") GETWINDOWPROPFN (* \; "Get window property value") PUTWINDOWPROPFN (* \; "Set window property value") BURYWFN (* \; "Move window behind all others") TOTOPWFN (* \; "Move iwindow in front of all others") IMPORTWFN (* \; "Take a native window and save its state internally") EXPORTWFN (* \; "Take a saved window state and open it on this screen, filling in screen and methods as needed.") DESTROYFN (* \; "Destroy this window, for GC finaliszation") SETCURSORFN (* \; "Set the cursor for this window.") PROMPTW (* \; "The prompt window for this screen") SHOWGCFN (* \; "Show GC indication; called with ON/OFF arg, t=>show gcing status, NIL=>turn off GC indicator.") DSPCREATEFN (* \; "Create a displaystream on this screen.") BBTTOWIN (* \; "BITBLT from a lisp bitmap to a window") BBTFROMWIN (* \; "BITBLT from a window to a lisp bitmap") BBTWINWIN (* \; "BITBLT from a window to another window.") SCCURSOR (* \; "CURSOR that's in effect for this screen by default.") SCKEYBOARD (* \; "Something about which keyboard we're receiving from.") SCDEPTH (* \; "# of bits per pixel on the screen. THIS WILL REPLACE SCBITSPERPIXEL ASAP.") SCCLOSEDOWN (* \; "Close down this screen cleanly, saving window state.") SCCLOSESCREEN (* \; "Close down thie screen cleanly, no state saving.") SCREOPEN (* \; "Reopen this screen?") SCCARETFLASH (* \; "Function to flash thecaret.") SCGETSCREENPOSITION (* \; "GETSCREENPOSITION") SCGETBOXSCREENPOSITION (* \; "GETBOXPOSITION") SCGETSCREENREGION (* \; "GETREGION") SCMOVEPOINTER (* \; "\\CURSORPOSITION")) SCONOFF _ (QUOTE OFF) (ACCESSFNS ((SCBITSPERPIXEL (COND ((|fetch| (SCREEN SCDESTINATION) |of| DATUM) (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| (|fetch| (SCREEN SCDESTINATION) |of| DATUM))) (T 1))) (SCREGION (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (|fetch| (SCREEN SCWIDTH) |of| DATUM) HEIGHT _ (|fetch| (SCREEN SCHEIGHT) |of| DATUM))))) (SYSTEM)) (GLOBALVARS WINDOWUSERFORMS ENDOFWINDOWUSERFORMS PROMPTWINDOW) (PUTPROP (QUOTE WINDOW) (QUOTE IMPORTDATE) (IDATE " 9-Apr-2000 17:36:29")) (PUTPROPS NNLITATOM MACRO (OPENLAMBDA (X) (AND X (LITATOM X)))) (PUTPROPS \\NULL.OR.FIXP MACRO (OPENLAMBDA (X) (OR (NULL X) (FIXP X)))) (PUTPROPS \\CHECKTYPE MACRO (X (PROG ((VAR (CAR X)) (PRED (CADR X))) (|if| (AND (LISTP PRED) (MEMB ( CAR PRED) (QUOTE (QUOTE FUNCTION)))) |then| (SETQ PRED (LIST (CADR PRED) VAR))) (RETURN (SUBPAIR ( QUOTE (MSG VAR PRED)) (LIST (CONCAT " is not a suitable value for the variable: " VAR) VAR PRED) (QUOTE (|until| PRED |do| (SETQ VAR ( ERROR VAR MSG))))))))) (PUTPROPS CANONICAL.TIMERUNITS MACRO (OPENLAMBDA (X) (* |Checks| |for| |common| |abbreviations| |before| |calling| |\\CanonicalizeTimerUnits|) (SELECTQ X ((TICKS MILLISECONDS SECONDS) (* |These| |are| |the| |canonical| |forms|) X) (NIL (QUOTE MILLISECONDS)) (|\\CanonicalizeTimerUnits| X)))) (PUTPROPS \\MACRO.EVAL DMACRO (Z (PROG ((X (EXPANDMACRO (CAR Z) T))) (|if| (EQ X (CAR Z)) |then| ( ERROR "No macro property -- \\MACRO.EVAL" X) |else| (RETURN (EVAL X)))))) (DEFOPTIMIZER \\MACRO.MX (FORM) FORM) (PUTPROP (QUOTE MACROAUX) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:26:31")) (RPAQQ MASK0WORD1\'S 32767) (RPAQQ MASK1WORD0\'S 32768) (RPAQQ MASKWORD1\'S 65535) (RPAQQ MASKHALFWORD1\'S 255) (RPAQQ BITSPERHALFWORD 8) (CONSTANTS MASK0WORD1\'S MASK1WORD0\'S MASKWORD1\'S MASKHALFWORD1\'S BITSPERHALFWORD) (PUTPROPS EQZEROP MACRO ((X) (EQ 0 X))) (PUTPROPS \\MOVETOBOX DMACRO (OPENLAMBDA (N D) (SELECTC (NTYPX N) (\\SMALLP (|replace| (FIXP HINUM) |of| D |with| 0) (|replace| (FIXP LONUM) |of| D |with| N)) (\\FIXP (|replace| (FIXP HINUM) |of| D |with| (|fetch| (FIXP HINUM) |of| N)) (|replace| (FIXP LONUM) |of| D |with| (|fetch| (FIXP LONUM) |of| N))) (\\ILLEGAL.ARG N)))) (PUTPROPS .XUNBOX. MACRO ((X HX LX) (|until| (SETQ LX (SELECTC (NTYPX X) (\\SMALLP (COND ((IGEQ X 0) ( SETQ HX 0) X) (T (SETQ HX MASKWORD1\'S) (\\LOLOC X)))) (\\FIXP (SETQ HX (|fetch| (FIXP HINUM) |of| X)) (|fetch| (FIXP LONUM) |of| X)) NIL)) |do| (SETQ X (LISPERROR "ILLEGAL ARG" X T))))) (PUTPROPS .XLLSH. MACRO ((HI LO N) (|if| (IGEQ N BITSPERWORD) |then| (* \; "Jump 16 bits in a single bound!") (SETQ HI LO) (SETQ LO 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) ( |if| (IGEQ N BITSPERHALFWORD) |then| (* \; "Jump 8 bits in a single bound!") (SETQ HI (LOGOR ( .LOHALFWORDHI. HI) (.HIHALFWORDLO. LO))) (SETQ LO (.LOHALFWORDHI. LO)) (SETQ N (IDIFFERENCE N BITSPERHALFWORD))) (|if| (IGEQ N 4) |then| (* \; "Jump 4 bits in a single bound!") (SETQ HI (LOGOR ( LRSH LO (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LLSH (LOGAND HI (CONSTANT (MASK.1\'S 0 (IDIFFERENCE BITSPERWORD 4)))) 4))) (SETQ LO (LLSH (LOGAND LO (CONSTANT (MASK.1\'S 0 (IDIFFERENCE BITSPERWORD 4)))) 4)) (SETQ N (IDIFFERENCE N 4))) (* \; "MASK0WORD1'S should be same as (SUB1 (LSH 1 (SUB1 BITSPERWORD)))") (FRPTQ N (SETQ HI (LLSH (LOGAND HI MASK0WORD1\'S) 1)) (SETQ LO (LLSH (|if| (IGEQ LO MASK1WORD0\'S) |then| (|add| HI 1) (LOGAND LO MASK0WORD1\'S) |else| LO) 1))))) (PUTPROPS .XLLSH1. MACRO ((HI LO) (SETQ HI (LLSH (LOGAND HI MASK0WORD1\'S) 1)) (SETQ LO (LSH (COND (( IGEQ LO MASK1WORD0\'S) (SETQ HI (LOGOR HI 1)) (LOGAND LO MASK0WORD1\'S)) (T LO)) 1)))) (PUTPROPS .XLRSH. MACRO ((HI LO N) (|if| (IGEQ N BITSPERWORD) |then| (* \; "Jump 10 bits in a single bound!") (SETQ LO HI) (SETQ HI 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) ( |if| (IGEQ N BITSPERHALFWORD) |then| (* \; "Jump 8 bits in a single bound!") (SETQ LO (LOGOR ( .HIHALFWORDLO. LO) (.LOHALFWORDHI. HI))) (SETQ HI (.HIHALFWORDLO. HI)) (SETQ N (IDIFFERENCE N BITSPERHALFWORD))) (|if| (IGEQ N 4) |then| (* \; "Jump 4 bits in a single bound!") (SETQ LO (LOGOR ( LLSH (LOGAND HI (CONSTANT (MASK.1\'S 0 4))) (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LRSH LO 4))) ( SETQ HI (LRSH HI 4)) (SETQ N (IDIFFERENCE N 4))) (* \; "MASK1WORD0'S should be same as \\SIGNBIT") ( FRPTQ N (SETQ LO (|if| (ODDP HI) |then| (LOGOR (LRSH LO 1) MASK1WORD0\'S) |else| (LRSH LO 1))) (SETQ HI (LRSH HI 1))))) (PUTPROPS .ADD.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* \; "Ignores carry out of high-order word") ( SETQ HX (.SUMSMALLMOD. HX HY)) (SETQ LX (.SUMSMALLMOD. LX LY (SETQ HX (|if| (EQ HX MAX.SMALL.INTEGER) |then| 0 |else| (ADD1 HX))))))) (PUTPROPS .SUB.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* \; "Ignores carry out of high-order word") ( SETQ HX (.DIFFERENCESMALLMOD. HX HY)) (SETQ LX (.DIFFERENCESMALLMOD. LX LY (SETQ HX (|if| (EQ HX 0) |then| MAX.SMALL.INTEGER |else| (SUB1 HX))))))) (PUTPROPS .32BITMUL. MACRO ((HR LR X Y) (PROG (HX LX HY LY) (|if| (ILESSP X Y) |then| (|swap| X Y)) (* \; "Y is the lesser of the two now") (.XUNBOX. X HX LX) (.XUNBOX. Y HY LY) LP (|if| (ODDP LY) |then| (.ADD.2WORD.INTEGERS. HR LR HX LX)) (|if| (EQ HY 0) |then| (SETQ LY (LRSH LY 1)) (|if| (EQ LY 0) |then| (RETURN)) |else| (.LRSH1. HY LY)) (* \; "Trim off highest bits, so that left-shifting doesn't generate FIXPs") (SETQ HX (LOGAND HX MASK0WORD1\'S)) (.LLSH1. HX LX) (GO LP)))) (PUTPROPS .SUMSMALLMOD. MACRO ((X Y OVERFLOWFORM) ((LAMBDA (|\\SumSmallModVar|) (DECLARE (LOCALVARS |\\SumSmallModVar|)) (IF (ILEQ X |\\SumSmallModVar|) THEN (IPLUS X Y) ELSE OVERFLOWFORM (IDIFFERENCE X (ADD1 |\\SumSmallModVar|)))) (IDIFFERENCE MAX.SMALL.INTEGER Y)))) (PUTPROPS .DIFFERENCESMALLMOD. MACRO ((X Y BORROWFORM) (IF (NOT (IGREATERP Y X)) THEN (IDIFFERENCE X Y ) ELSE BORROWFORM (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (IDIFFERENCE Y X)))))) (PUTPROPS \\GETBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (|\\Byte|) (DECLARE (LOCALVARS |\\Byte|)) (|if| (ODDP OFFST) |then| (LOGAND |\\Byte| (CONSTANT (MASK.1\'S 0 BITSPERNIBBLE))) |else| ( LRSH |\\Byte| BITSPERNIBBLE))) (\\GETBASEBYTE BASE (FOLDLO OFFST NIBBLESPERBYTE))))) (PUTPROPS \\PUTBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (|\\ByteNo|) (DECLARE ( LOCALVARS |\\ByteNo|)) ((LAMBDA (|\\Byte|) (DECLARE (LOCALVARS |\\Byte|)) (\\PUTBASEBYTE BASE |\\ByteNo| (|if| (ODDP OFFST) |then| (LOGOR (LOGAND |\\Byte| (CONSTANT (MASK.1\'S BITSPERNIBBLE BITSPERNIBBLE))) VAL) |else| (LOGOR (LOGAND |\\Byte| (CONSTANT (MASK.1\'S 0 BITSPERNIBBLE))) (LLSH VAL BITSPERNIBBLE))))) (\\GETBASEBYTE BASE |\\ByteNo|))) (FOLDLO OFFST NIBBLESPERBYTE)))) (PUTPROPS \\GETBASEBIT DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (|\\ByteNo| |\\BitMask|) (DECLARE ( LOCALVARS |\\ByteNo| |\\BitMask|)) (|if| (EQ 0 (LOGAND |\\BitMask| (\\GETBASEBYTE BASE |\\ByteNo|))) |then| 0 |else| 1)) (FOLDLO OFFST BITSPERBYTE) (MASK.1\'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) ( IMOD OFFST BITSPERBYTE)) 1)))) (PUTPROPS \\PUTBASEBIT DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (|\\ByteNo| |\\BitMask| |\\Byte|) (DECLARE (LOCALVARS |\\ByteNo| |\\BitMask| |\\Byte|)) (SETQ |\\Byte| (\\GETBASEBYTE BASE |\\ByteNo|)) (|if| (|if| (EQ 0 (LOGAND |\\BitMask| |\\Byte|)) |then| (NOT (EQ 0 VAL)) |else| (EQ 0 VAL)) |then| ( \\PUTBASEBYTE BASE |\\ByteNo| (LOGXOR |\\BitMask| |\\Byte|))) VAL) (FOLDLO OFFST BITSPERBYTE) ( MASK.1\'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) (IMOD OFFST BITSPERBYTE)) 1)))) (PUTPROP (QUOTE ADDARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 11:46:37")) (RPAQQ \\MAXFILEPAGE 65534) (CONSTANTS \\MAXFILEPAGE) (PUTPROP (QUOTE LLFAULT) (QUOTE IMPORTDATE) (IDATE " 2-Jan-1993 12:26:58")) (PUTPROPS \\UPDATETIMERS MACRO (NIL (* * |Moves| |excess| |time| |from| |the| |processor| |clock| |to| |our| |software| |clocks.| |Needs| |to| |be| |run| |often,| |uninterruptably,| |preferably| |from| |the| |vertical| |retrace| |interrupt|) (* |Get| |processor| |clock|) (PROG ((EXCESS (\\BOXIDIFFERENCE (\\RCLK (LOCF (|fetch| RCLKTEMP0 |of| \\MISCSTATS))) (LOCF (|fetch| BASECLOCK |of| \\MISCSTATS))))) ( RETURN (COND ((OR (IGEQ EXCESS \\RCLKSECOND) (ILESSP EXCESS 0)) (* |More| |than| |one| |second| |has| |elapsed| |since| |we| |updated| |clocks|) (\\BOXIPLUS (LOCF (|fetch| BASECLOCK |of| \\MISCSTATS)) \\RCLKSECOND) (* |Increment| |base| |by| |one| |second|) (\\BOXIPLUS (LOCF (|fetch| MILLISECONDSCLOCK |of| \\MISCSTATS)) 1000) (* |Increment| |clocks| |by| 1 |second|) (\\BOXIPLUS (LOCF (|fetch| SECONDSCLOCK |of| \\MISCSTATS)) 1) T)))))) (RPAQQ \\RTCSECONDS 378) (RPAQQ \\RTCMILLISECONDS 380) (RPAQQ \\RTCBASE 382) (RPAQQ \\OFFSET.SECONDS 0) (RPAQQ \\OFFSET.MILLISECONDS 2) (RPAQQ \\OFFSET.BASE 4) (RPAQQ \\ALTO.RCLKSECOND 1680000) (RPAQQ \\ALTO.RCLKMILLISECOND 1680) (RPAQQ \\DLION.RCLKMILLISECOND 35) (RPAQQ \\DLION.RCLKSECOND 34746) (RPAQQ \\DOVE.RCLKMILLISECOND 63) (RPAQQ \\DOVE.RCLKSECOND 62500) (CONSTANTS (\\RTCSECONDS 378) (\\RTCMILLISECONDS 380) (\\RTCBASE 382) (\\OFFSET.SECONDS 0) ( \\OFFSET.MILLISECONDS 2) (\\OFFSET.BASE 4) (\\ALTO.RCLKSECOND 1680000) (\\ALTO.RCLKMILLISECOND 1680) ( \\DLION.RCLKMILLISECOND 35) (\\DLION.RCLKSECOND 34746) (\\DOVE.RCLKMILLISECOND 63) (\\DOVE.RCLKSECOND 62500)) (PUTPROPS ALTO.TO.LISP.DATE MACRO ((DATE) (LOGXOR DATE -2147483648))) (PUTPROPS LISP.TO.ALTO.DATE MACRO ((DATE) (LOGXOR DATE -2147483648))) (PUTPROP (QUOTE LLTIMER) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:13:11")) (DATATYPE SYSQUEUE ((NIL BYTE) (SYSQUEUEHEAD POINTER) (NIL BYTE) (SYSQUEUETAIL POINTER))) (BLOCKRECORD QABLEITEM ((NIL BITS 4) (QLINK POINTER) (* \; "Link to next thing in queue always in first pointer of datum, independent of what the datum is")) ( BLOCKRECORD QABLEITEM ((NIL BITS 4) (LINK POINTER) (* \; "Let's also be able to call it a LINK")))) (PUTPROPS \\QUEUEHEAD MACRO ((Q) (|fetch| (SYSQUEUE SYSQUEUEHEAD) |of| Q))) (PUTPROPS \\DETCONC MACRO (OPENLAMBDA (TQ) (PROG1 (\\PEEKTCONC TQ) (|if| (NULL (CAR (RPLACA TQ (CDAR TQ)))) |then| (RPLACD TQ))))) (PUTPROPS \\ENTCONC MACRO (= . TCONC)) (PUTPROPS \\PEEKTCONC MACRO (= . CAAR)) (DATATYPE ETHERPACKET ((NIL BYTE) (EPLINK POINTER) (* \; "For queue maintenence") (EPFLAGS BYTE) (* \; "optional flags for some applications") (EPUSERFIELD POINTER) (* \; "Arbitrary pointer for applications") (NIL BYTE) (EPPLIST POINTER) (* \; "Extra field for use as an A-list for properties") (EPTRANSMITTING FLAG) (* \; "True while packet is being transmitted and hence cannot be reused") (EPRECEIVING FLAG) (* \; "True when a packet has been seen at the head of the network's input queue at least once") (NIL BITS 6 ) (EPREQUEUE POINTER) (* \; "Where to requeue this packet after transmission") (NIL BYTE) (EPSOCKET POINTER) (NIL BYTE) (EPNETWORK POINTER) (EPTYPE WORD) (* \; "Type of packet to be encapsulated (PUP or XIP or 10TO3)") (NIL WORD) (EPTIMESTAMP FIXP) (* \; "Gets RCLK value when transmitted/received") (EPREQUEUEFN POINTER) (* \; "FN to perform requeueing") ( NIL 4 WORD) (* \; "Space for expansion") (* \; "Note: This next field wants to be quad+2 aligned so that the 10mb packet is quad+3 aligned") ( EPENCAPSULATION 8 WORD) (* \; "10mb encapsulation, or 3mb encapsulation with padding") (EPBODY 289 WORD) (* \; "Body of packet, header up to 16 words plus data up to 546 bytes"))) (ACCESSFNS ETHERAUX ((AUXPTR (CDR (ASSOC (QUOTE AUXPTR) (|fetch| EPPLIST |of| DATUM))) (\\EP.PUT.AUX DATUM (QUOTE AUXPTR) NEWVALUE)) (AUXWORD (OR (CDR (ASSOC (QUOTE AUXWORD) (|fetch| EPPLIST |of| DATUM)) ) 0) (\\EP.PUT.AUX DATUM (QUOTE AUXWORD) NEWVALUE)) (AUXBYTE (OR (CDR (ASSOC (QUOTE AUXBYTE) (|fetch| EPPLIST |of| DATUM))) 0) (\\EP.PUT.AUX DATUM (QUOTE AUXBYTE) NEWVALUE)))) (RPAQQ \\EPT.PUP 512) (RPAQQ \\EPT.XIP 1536) (RPAQQ \\3MBTYPE.XIP 1536) (RPAQQ \\10MBTYPE.XIP 1536) (RPAQQ \\EPT.10TO3 1537) (RPAQQ \\3MBTYPE.10TO3 1537) (RPAQQ \\EPT.UNKNOWN 255) (CONSTANTS \\EPT.PUP \\EPT.XIP \\3MBTYPE.XIP \\10MBTYPE.XIP \\EPT.10TO3 \\3MBTYPE.10TO3 \\EPT.UNKNOWN) (RPAQQ \\NULLCHECKSUM 65535) (CONSTANTS (\\NULLCHECKSUM 65535)) (DATATYPE NDB ((NETTYPE BYTE) (* \; "10 or 3 for now") (NDBNEXT POINTER) (* \; "Link to next NDB") ( NDBPUPNET# BYTE) (* \; "Pup number of this net. May be different from NS net number, though not in Xerox world") (NDBNSNET# POINTER) (* \; "Can be 32-bits, so might as well leave its box around") (NDBTASK# BYTE) (* \; "Task # of this network") (NDBBROADCASTP POINTER) (* \; "Function that returns true if packet is of broadcast type") (NDBPUPHOST# BYTE) (* \; "My pup address on this net. NS address is global to all nets, so not needed here") (NDBTRANSMITTER POINTER) (* \; "(NDB PACKET) -- fn to send a raw packet on this net. returns NIL on failure") (NIL BYTE) (NDBENCAPSULATOR POINTER) (* \; "(NDB PACKET HOST LENGTH TYPE) -- fn to encapsulate and send a higher-level packet on this net ") ( NDBCSB POINTER) (* \; "Pointer to CSB for this network") (NDBIQLENGTH BYTE) (NDBIQ POINTER) (* \; "Queue of empty packets for receiver") (NDBTQ POINTER) (* \; "Queue of packets to transmit") ( NDBTRANSLATIONS POINTER) (* \; "Cache of translations, 3:10 or 10:3 according to network") ( NDBETHERFLUSHER POINTER) (* \; "Turns off this ether. Args NDB") (NDBWATCHER POINTER) (NDBCANHEARSELF POINTER) (* \; "True if receiver can hear packets sent by transmitter") (NDBIPNET# POINTER) ( NDBIPHOST# POINTER) (NDBPUPTYPE WORD) (* \; "The packet encapsulation of PUP on this net") (NIL WORD) (NIL POINTER) (* \; "Spares"))) (RECORD ROUTING (RTNET# RTHOPCOUNT RTGATEWAY# RTNDB RTTIMER RTRECENT)) (PUTPROPS \\SERIALNUMBER MACRO (NIL (|fetch| (IFPAGE |SerialNumber|) |of| |\\InterfacePage|))) (PUTPROPS \\DEVICE.INPUT DOPVAL (1 MISC1 1)) (PUTPROPS \\DEVICE.OUTPUT DOPVAL (2 MISC2 2)) (PUTPROPS \\D0.STARTIO DOPVAL (1 MISC1 0)) (PUTPROP (QUOTE LLETHER) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 10:49:30")) (RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR) BRUSHSHAPE _ (QUOTE ROUND) BRUSHSIZE _ 1) (PUTPROPS IMAGEOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) ( QUOTE QUOTE)) (LIST (QUOTE |fetch|) (LIST (QUOTE IMAGEOPS) (CADAR ARGS)) (QUOTE |of|) (LIST (QUOTE |fetch|) (QUOTE (STREAM IMAGEOPS)) (QUOTE |of|) (CADR ARGS)))) (T (HELP "IMAGEOP - OPNAME not quoted:" ARGS))) (CDDR ARGS))))) (DATATYPE IMAGEOPS (IMAGETYPE IMCLOSEFN IMXPOSITION IMYPOSITION IMFONT IMLEFTMARGIN IMRIGHTMARGIN IMLINEFEED IMDRAWLINE IMDRAWCURVE IMDRAWCIRCLE IMDRAWELLIPSE IMFILLCIRCLE IMBLTSHADE IMBITBLT IMNEWPAGE IMMOVETO IMSCALE IMTERPRI IMTOPMARGIN IMBOTTOMMARGIN IMSPACEFACTOR IMFONTCREATE IMOPERATION IMCOLOR IMSTRINGWIDTH IMCHARWIDTH IMCHARWIDTHY IMBACKCOLOR IMBITMAPSIZE IMCLIPPINGREGION IMRESET IMDRAWPOLYGON IMFILLPOLYGON IMSCALEDBITBLT IMWRITEPIXEL IMCHARSET IMROTATE IMDRAWARC IMTRANSLATE IMSCALE2 IMPUSHSTATE IMPOPSTATE IMDEFAULTSTATE IMDRAWPOINT IMBLTCHAR IMXOFFSET IMYOFFSET) IMCLOSEFN _ (FUNCTION NILL) IMTERPRI _ (FUNCTION (LAMBDA (STREAM) (\\OUTCHAR STREAM (CHARCODE EOL)))) IMNEWPAGE _ (FUNCTION (LAMBDA (STREAM) (\\OUTCHAR STREAM (CHARCODE ^L)))) IMOPERATION _ (FUNCTION NILL) IMCOLOR _ (FUNCTION NILL) IMCLIPPINGREGION _ (FUNCTION NILL) IMRESET _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION NILL) IMSTRINGWIDTH _ (FUNCTION (LAMBDA (STREAM STR RDTBL) (STRINGWIDTH STR (DSPFONT NIL STREAM) RDTBL RDTBL))) IMCHARWIDTH _ (FUNCTION (LAMBDA (STREAM CHARCODE) (CHARWIDTH CHARCODE (DSPFONT NIL STREAM))) ) IMMOVETO _ (FUNCTION (LAMBDA (STREAM X Y) (IMAGEOP (QUOTE IMXPOSITION) STREAM STREAM X) (IMAGEOP ( QUOTE IMYPOSITION) STREAM STREAM Y))) IMBITMAPSIZE _ (FUNCTION (LAMBDA (STREAM BITMAP DIMENSION) ( SELECTQ DIMENSION (WIDTH (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP))) (HEIGHT (TIMES (DSPSCALE NIL STREAM) (BITMAPHEIGHT BITMAP))) (NIL (CONS (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP)) ( TIMES (DSPSCALE NIL STREAM) (BITMAPHEIGHT BITMAP)))) (\\ILLEGAL.ARG DIMENSION)))) IMWRITEPIXEL _ ( FUNCTION NILL) IMCHARSET _ (FUNCTION NILL) IMXPOSITION _ (FUNCTION NILL) IMYPOSITION _ (FUNCTION NILL) IMFONT _ (FUNCTION NILL) IMLEFTMARGIN _ (FUNCTION NILL) IMRIGHTMARGIN _ (FUNCTION NILL) IMLINEFEED _ (FUNCTION NILL) IMDRAWLINE _ (FUNCTION NILL) IMDRAWCURVE _ (FUNCTION NILL) IMDRAWCIRCLE _ (FUNCTION NILL) IMDRAWELLIPSE _ (FUNCTION NILL) IMFILLCIRCLE _ (FUNCTION NILL) IMBLTSHADE _ (FUNCTION NILL) IMBITBLT _ (FUNCTION NILL) IMSCALE _ (FUNCTION NILL) IMTOPMARGIN _ (FUNCTION NILL) IMBOTTOMMARGIN _ ( FUNCTION NILL) IMSPACEFACTOR _ (FUNCTION NILL) IMFONTCREATE _ (FUNCTION NILL) IMCHARWIDTHY _ (FUNCTION NILL) IMDRAWPOLYGON _ (FUNCTION \\DRAWPOLYGON.GENERIC) IMDRAWPOINT _ (FUNCTION \\DRAWPOINT.GENERIC) IMFILLPOLYGON _ (FUNCTION NILL) IMSCALEDBITBLT _ (FUNCTION NILL) IMROTATE _ (FUNCTION NILL) IMDRAWARC _ (FUNCTION NILL) IMTRANSLATE _ (FUNCTION NILL) IMPUSHSTATE _ (FUNCTION NILL) IMPOPSTATE _ (FUNCTION NILL) IMSCALE2 _ (FUNCTION NILL) IMDEFAULTSTATE _ (FUNCTION NILL) IMBLTCHAR _ (FUNCTION \\MEDW.BLTCHAR ) IMXOFFSET _ (FUNCTION \\MEDW.XOFFSET) IMYOFFSET _ (FUNCTION \\MEDW.YOFFSET)) (GLOBALVARS \\NOIMAGEOPS) (PUTPROP (QUOTE IMAGEIO) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:33:59")) (DATATYPE PROCESS ((PROCFX0 WORD) (* \; "= \\STACKHI to make this look like a STACKP") (PROCFX WORD) ( * \; "Stack pointer to this context when it is asleep") (PROCSTATUS BYTE) (* \; "Running or waiting") (PROCNAME POINTER) (* \; "Name for convenience in type-in reference") (PROCPRIORITY BYTE) (* \; "Priority level, 0-4. Not currently used.") (PROCQUEUE POINTER) (* \; "Queue of processes at the same priority") (NIL BYTE) (NEXTPROCHANDLE POINTER) (* \; "Pointer to next one") (PROCTIMERSET FLAG) (* \; "True if PROCWAKEUPTIMER has an interesting value") ( PROCBEINGDELETED FLAG) (* \; "True if proc was deleted, but hasn't been removed from \\PROCESSES yet") (PROCDELETED FLAG) (PROCSYSTEMP FLAG) (PROCNEVERSTARTED FLAG) (NIL FLAG) (NIL FLAG) (NIL FLAG) ( PROCWAKEUPTIMER POINTER) (* \; "a largep recording the time this proc last went to sleep") ( PROCTIMERLINK POINTER) (* \; "For linking proc in timer queue") (PROCTIMERBOX POINTER) (* \; "Scratch box to use for PROCWAKEUPTIMER when user does not give one explicitly") (WAKEREASON POINTER) (* \; "Reason process is being run. From WAKE.PROCESS or timer or event wakeup; T from simple BLOCK" ) (PROCEVENTORLOCK POINTER) (* \; "EVENT or MONITOR lock that this proc is waiting for") (PROCFORM POINTER) (* \; "Form to EVAL to start it going") (RESTARTABLE POINTER) (* \; "T = autorestart on error, HARDRESET = restart only on hard reset, NIL = never restart") (PROCWINDOW POINTER) (* \; "Window this process lives in, if any") (PROCFINISHED POINTER) (* \; "True if proc finished. Value is indication of how: NORMAL, DELETED, ERROR") (PROCRESULT POINTER) (* \; "Value it returned if it finished normally") (PROCFINISHEVENT POINTER) (* \; "Optional EVENT to be notified when proc finishes") (PROCMAILBOX POINTER) (* \; "Message queue") ( PROCDRIBBLEOUTPUT POINTER) (* \; "Binding for *DRIBBLE-OUTPUT* in this process") (PROCINFOHOOK POINTER ) (* \; "Optional user fn that displays info about process") (PROCTYPEAHEAD POINTER) (* \; "Buffer of typeahead destined for this proc") (PROCREMOTEINFO POINTER) (* \; "For Enterprise") ( PROCUSERDATA POINTER) (* \; "For PROCESSPROP") (PROCEVENTLINK POINTER) (* \; "Used to maintain EVENT queues") (PROCAFTEREXIT POINTER) (* \; "What to do with this process when coming back from a LOGOUT, etc") (PROCBEFOREEXIT POINTER) (* \; "If DON'T, can't logout") (PROCOWNEDLOCKS POINTER) (* \; "Pointer to first lock I currently own") ( PROCEVAPPLYRESULT POINTER) (* \; "For PROCESS.EVAL and PROCESS.APPLY when WAITFORRESULT is true") ( PROCTTYENTRYFN POINTER) (* \; "Is applied to a process when it becomes the tty process") ( PROCTTYEXITFN POINTER) (* \; "Is applied to a process when it ceases to be the tty process") ( PROCHARDRESETINFO POINTER) (* \; "HARDRESET stores info about unwind-protect cleanups here") ( PROCRESTARTFORM POINTER) (* \; "use this instead of PROCFORM when restarting") (PROCOLDTTYPROC POINTER ) (* \; "Process that had the tty when we got it") (NIL POINTER) (* \; "For expansion")) PROCTIMERBOX _ (CREATECELL \\FIXP) PROCFX0 _ \\STACKHI) (PUTPROPS THIS.PROCESS MACRO (NIL \\RUNNING.PROCESS)) (PUTPROPS TTY.PROCESS MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE \\TTY.PROCESS))))) (PUTPROPS TTY.PROCESSP MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE (OR (NULL (THIS.PROCESS) ) (EQ (THIS.PROCESS) (TTY.PROCESS)))))))) (GLOBALVARS \\RUNNING.PROCESS \\TTY.PROCESS \\PROC.RESTARTME \\PROC.RESETME \\PROC.ABORTME) (PUTPROP (QUOTE PROC) (QUOTE IMPORTDATE) (IDATE "17-Jun-1999 21:58:52")) (PUTPROPS \\BACKCHAR MACRO (OPENLAMBDA (STREAM) (* \; "Backs up over an NS character") (\\BACKNSCHAR STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)))) (PUTPROPS \\BACKNSCHAR MACRO ((ST SHIFTEDCHARSET COUNTERVAR) (COND ((\\XCCSP ST) (\\BACKXCCSCHAR ST SHIFTEDCHARSET COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR ( CL:FUNCALL (|ffetch| (STREAM BACKCHARFN) |of| ST) ST T)))) (T (CL:FUNCALL (|ffetch| (STREAM BACKCHARFN ) |of| ST) ST NIL))))))) (PUTPROPS \\CHECKEOLC MACRO (OPENLAMBDA (CH EOLC STREAM PEEKBINFLG COUNTERVAR) (* |;;| "Subtracts number of bytes read from COUNTERVAR, which may be NIL. In fact, should be NIL if PEEKBINFLG is T." ) (SELCHARQ CH (CR (SELECTC EOLC (CR.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND (PEEKBINFLG (* |;;| "T from PEEKC, compile-time constant. In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts" ) (COND ((EQ (CHARCODE LF) (UNINTERRUPTABLY (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* |;;| "Read the NS CR. We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \\NSPEEK that got the CR character. Since we are going to NS back the CR character, we don't need to update the counter variable" ) (PROG1 (\\PEEKBIN STREAM T) (* |;;| "LF must be in next BYTE after NS CR, regardless of coding. Character-set shifting bytes can't intervene. Then we back up over the CR that was \\NSINed above." ) (\\BACKNSCHAR STREAM)))) (CHARCODE EOL)) (T (CHARCODE CR)))) ((EQ (CHARCODE LF) (\\PEEKBIN STREAM T) ) (\\BIN STREAM) (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (SUB1 COUNTERVAR))) (CHARCODE EOL)) (T ( CHARCODE CR)))) (CHARCODE CR))) (LF (COND ((EQ EOLC LF.EOLC) (CHARCODE EOL)) (T (CHARCODE LF)))) CH))) (PUTPROPS \\INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* \; "returns a 16 bit character code") ( \\CHECKEOLC (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (FFETCH EOLCONVENTION OF STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \\INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* \; "returns a 16 bit character code") ( \\CHECKEOLC (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (|ffetch| EOLCONVENTION |of| STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \\PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR) (\\CHECKEOLC (\\NSPEEK STREAM (UNFOLD ( ACCESS-CHARSET STREAM) 256) NIL NOERROR) (|ffetch| EOLCONVENTION |of| STREAM) STREAM T))) (PUTPROPS \\NSIN MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* |;;;| "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here." ) (COND ((\\XCCSP ST) (\\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR ) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (|ffetch| (STREAM INCCODEFN) |of| ST) ST T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (|ffetch| (STREAM INCCODEFN) |of| ST) ST NIL))))))) (PUTPROPS \\NSPEEK MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* |;;;| "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here." ) (COND ((\\XCCSP ST) (\\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST) 256) NIL NOERROR)) (T (COND ((QUOTE COUNTERVAR) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (|ffetch| (STREAM PEEKCCODEFN) |of| ST) ST NOERROR T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (|ffetch| ( STREAM PEEKCCODEFN) |of| ST) ST NOERROR NIL))))))) (PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET)) (PUTPROPS \\CONV.JIS.TO.XCCS MACRO (OPENLAMBDA (KU TEN) (* |;;;| "Some character code is not equivalent between JIS and XCCS. In such case, we have to convert the character to corresponding XCCS." ) (COND ((\\NOT.EQUIVALENT.TO.XCCS KU) (\\DO.CONV.JIS.TO.XCCS KU TEN)) (T (LOGOR (UNFOLD KU 256) TEN)) ))) (PUTPROPS \\DO.CONV.JIS.TO.XCCS MACRO ((KU TEN) (* |;;;| " Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.") (COND ((\\INVALID.TENP TEN) *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (SELECTQ KU ((33 34 38) (* \; "1, 2 and 6 KU") (LET* ((CONVTABLE (\\EXTARACT.CONV.TABLE KU)) (SET (\\EXTRACT.SET TEN CONVTABLE)) ( CODE (\\EXTRACT.CODE TEN CONVTABLE))) (COND ((NEQ SET 255) (LOGOR (UNFOLD SET 256) CODE)) (T (COND (( EQ CODE 255) (* \; "Not defined in JIS.") *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (* \; "Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.") (COND ( *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 256) TEN)))))))))) (35 (* \; "3 KU") (* \; "Alpha numeric codes are all defined as single byte codes in XCCS.") TEN) (40 (* \; "8 KU") (COND ((< 0 TEN 33) (COND (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\\EXTRACT.NO.FONT.CODE ( LOGOR KU TEN))))) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (116 (* \; "84 KU") (COND ((< 0 TEN 5) (LOGOR 29952 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (117 (* \; "85 KU") (COND ((< 0 TEN 28) (LOGOR 29696 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) *DEFAULT-NOT-CONVERTED-FAT-CODE*))))) (PUTPROPS \\CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC) (* |;;;| "Returns JIS code corresponding to XCCS charcode. Handle HANKAKU as well as ZENKAKU. If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so. Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode." ) (OR (COND ((\\ASCIIP CC) CC) ((\\NOT.EQUIVALENT.TO.JIS CC) (\\DO.CONV.XCCS.TO.JIS CC)) (( \\CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM) (* \; "ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.") (\\CONV.ZENKAKU.KANA CC)) ( T CC)) CC))) (PUTPROPS \\DO.CONV.XCCS.TO.JIS MACRO ((CC) (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*))) (PUTPROPS \\ASCIIP MACRO (OPENLAMBDA (CC) (AND (EQ (FOLDLO CC 256) 0) (< (LOGAND CC 255) 128)))) (PUTPROPS \\NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC) (OR (EQ (FOLDLO CC 256) 0) (EQ (FOLDLO CC 256 ) 33) (EQ (FOLDLO CC 256) 34) (EQ (FOLDLO CC 256) 38) (EQ (FOLDLO CC 256) 40) (EQ (FOLDLO CC 256) 239) (EQ (FOLDLO CC 256) 241)))) (PUTPROPS \\CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM) (STREAMPROP OUTSTREAM :HTOZP))) (PUTPROPS \\CONV.ZENKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*))) (PUTPROPS \\XCCSIN MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* |;;;| "returns a 16 bit character code. SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes. COUNTERVAR if non-NIL is decremented by number of bytes read. Doesn't do EOL conversion -- \\INCHAR and \\INCCODE do that." ) (LET ((CHAR (\\BIN STREAM)) SCSET) (COND ((EQ CHAR NSCHARSETSHIFT) (* \; "Shifting character sets") (ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\\BIN STREAM))) (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* \; "2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3))) (EQ 0 (\\BIN STREAM))) \\NORUNCODE) (T (\\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ CHAR (\\BIN STREAM)) (SETQ SCSET (COND ((QUOTE SHIFTEDCSETVAR) (* \; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256))))) (T (SETQ SCSET SHIFTEDCSET))) ( COND ((EQ SCSET (UNFOLD \\NORUNCODE 256)) (* \; "just read two bytes and combine them to a 16 bit value") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR ( IDIFFERENCE COUNTERVAR 2))) (LOGOR (UNFOLD CHAR 256) (\\BIN STREAM))) (CHAR (AND (QUOTE COUNTERVAR) ( SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 1))) (AND CHAR (LOGOR SCSET CHAR))))))) (PUTPROPS \\XCCSPEEK MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* |;;| "Returns a 16 bit character code. Doesn't do EOL conversion--\\INCHAR does that. May actually read the character-set shift, storing the result in the stream. COUNTERVAR, if given, is updated to reflect any such bytes that are actually read" ) (PROG ((CHAR (\\PEEKBIN STREAM NOERROR)) SCSET) (COND ((NULL CHAR) (RETURN NIL)) ((EQ CHAR NSCHARSETSHIFT) (* \; "CHARSETVAR=NIL means don't set") (\\BIN STREAM) (* \; "Consume the char shift byte") (ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\\BIN STREAM))) (* \; "Note: no eof error check on this \\BIN -- an eof in the middle of a charset shift is an error") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* \; "2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3))) (EQ 0 (\\BIN STREAM))) \\NORUNCODE) (T (\\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ SCSET (COND ((QUOTE SHIFTEDCSETVAR) (* \; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR ( UNFOLD SCSET 256))) (T (UNFOLD SCSET 256)))) (COND ((NULL (SETQ CHAR (\\PEEKBIN STREAM NOERROR))) ( RETURN NIL)))) (T (SETQ SCSET SHIFTEDCSET))) (RETURN (COND ((EQ SCSET (UNFOLD \\NORUNCODE 256)) (* |;;| "just peek two bytes and combine them to a 16 bit value. Again, is an error if we hit eof in mid-character" ) (\\BIN STREAM) (PROG1 (LOGOR (UNFOLD CHAR 256) (\\PEEKBIN STREAM NOERROR)) (\\BACKFILEPTR STREAM))) (T (LOGOR SHIFTEDCSET CHAR))))))) (PUTPROPS \\BACKXCCSCHAR MACRO ((STREAM SHIFTEDCHARSET COUNTERVAR) (AND (\\BACKFILEPTR STREAM) (COND ( (COND (SHIFTEDCHARSET (EQ SHIFTEDCHARSET (UNFOLD \\NORUNCODE 256))) (T (EQ \\NORUNCODE (ACCESS-CHARSET STREAM)))) (COND ((\\BACKFILEPTR STREAM) (AND (QUOTE COUNTERVAR) (|add| COUNTERVAR 2)) T) ((QUOTE COUNTERVAR) (|add| COUNTERVAR 1)))) ((QUOTE COUNTERVAR) (|add| COUNTERVAR 1)))))) (PUTPROPS \\XCCSP MACRO (OPENLAMBDA (ST) (NOT (|ffetch| (STREAM NOTXCCS) |of| (\\DTEST ST (QUOTE STREAM)))))) (PUTPROPS \\EXTRACT.NO.FONT.CODE MACRO ((JISCODE) (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE* )))) (PUTPROPS \\EXTARACT.CONV.TABLE MACRO ((KU) (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*)))) (PUTPROPS \\NOT.EQUIVALENT.TO.XCCS MACRO ((KU) (* |;;;| " The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU. Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here." ) (OR (EQ KU 33) (EQ KU 34) (EQ KU 35) (EQ KU 38) (EQ KU 40) (EQ KU 116) (EQ KU 117)))) (PUTPROPS \\EXTRACT.SET MACRO ((TEN TABLE) (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32) 2) 1)) )) (PUTPROPS \\EXTRACT.CODE MACRO ((TEN TABLE) (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32) 2)))) (PUTPROPS \\CHNAGE.KI.MODE MACRO (OPENLAMBDA (ST INPUTFLG ENTERP) (* |;;;| "INPUTFLG is true if \\CHNAGE.KI.MODE is called in the context in which ST is an input stream.") (COND (INPUTFLG (COND (ENTERP (|freplace| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| T)) ( T (|freplace| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| NIL)))) (T (COND (ENTERP ( |freplace| (STREAM OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| T)) (T (|freplace| (STREAM OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| NIL))))))) (PUTPROPS \\KIMODEP MACRO (OPENLAMBDA (ST INPUTFLG) (* |;;;| "INPUTFLG is true if \\KIMODEP is called in the context in which ST is an input stream.") (COND ( INPUTFLG (|ffetch| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)))) (T (|ffetch| (STREAM OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM))))))) (PUTPROPS \\HANKAKUP MACRO ((CHAR) (< 160 CHAR 224))) (PUTPROPS \\KANJIP MACRO ((CHAR) (< 12158 CHAR 29733))) (PUTPROPS \\NOTGAIJIP MACRO ((CHAR) (OR (< 8480 CHAR 10305) (< 12158 CHAR 29733)))) (PUTPROPS \\INVALID.TENP MACRO (OPENLAMBDA (TEN) (OR (< TEN 33) (< 126 TEN)))) (PUTPROPS \\CONV.HANKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*))) (PUTPROPS \\OUTKI MACRO ((STREAM) (\\BOUT OUTSTREAM (CHARCODE ESC)) (\\BOUT OUTSTREAM (CHARCODE $)) ( \\BOUT OUTSTREAM (CHARCODE B)))) (PUTPROPS \\OUTKO MACRO ((STREAM) (\\BOUT OUTSTREAM (CHARCODE ESC)) (\\BOUT OUTSTREAM (CHARCODE \()) ( \\BOUT OUTSTREAM (CHARCODE J)))) (PUTPROPS \\CONV.SJIS.TO.JIS MACRO (OPENLAMBDA (HI LO) (* |;;;| "Convert Shift-JIS to JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively." ) (SETQ CH1 (IDIFFERENCE HI (COND ((> HI 159) 177) (T 113)))) (SETQ CH1 (IPLUS (UNFOLD CH1 2) 1)) ( SETQ CH2 (COND ((> LO 158) (PROG1 (IDIFFERENCE LO 126) (SETQ CH1 (IPLUS CH1 1)))) (T (IDIFFERENCE LO ( COND ((> LO 126) (IPLUS 31 1)) (T 31)))))))) (PUTPROPS \\CONV.JIS.TO.SJIS MACRO (OPENLAMBDA (HI LO) (* |;;;| "Convert JIS to Shift-JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively." ) (SETQ CH2 (COND ((ODDP HI) (SETQ CH2 (IPLUS LO 31)) (COND ((>= CH2 127) (IPLUS CH2 1)) (T CH2))) (T (IPLUS LO 126)))) (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33) 2) 129)) (AND (> CH1 159) (SETQ CH1 ( IPLUS CH1 64))))) (PUTPROPS \\SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR) (OR (< 127 CHAR 160) (< 223 CHAR 256)))) (PUTPROPS \\EUC.KANJI.FIRST.BYTEP MACRO ((CHAR) (< 160 CHAR 255))) (PUTPROPS \\GAIJIP MACRO ((CHAR) (EQ CHAR 143))) (PUTPROPS \\EUC.HANKAKUP MACRO ((CHAR) (EQ CHAR 142))) (PUTPROP (QUOTE LLREAD) (QUOTE IMPORTDATE) (IDATE " 4-Aug-1993 14:43:07")) (PUTPROPS EMPASSWORDLOC DMACRO (LAMBDA NIL (* |lmm| "24-MAR-83 06:46") (|fetch| (IFPAGE |UserPswdAddr| ) |of| |\\InterfacePage|))) (PUTPROPS \\DECRYPT.PWD.CHAR MACRO ((CHAR) (LOGXOR CHAR 73))) (PUTPROP (QUOTE PASSWORDS) (QUOTE IMPORTDATE) (IDATE "16-May-1990 21:02:21")) (RPAQQ MICASPERINCH 2540) (RPAQQ MICASPERMILLIMETER 100) (CONSTANTS (MICASPERINCH 2540) (MICASPERMILLIMETER 100)) (PUTPROP (QUOTE INTERPRESS) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 21:56:38")) (RPAQ MICASPERPT (FQUOTIENT 2540 72)) (RPAQQ IHALFMICASPERPT 17) (RPAQQ IMICASPERPT 35) (CONSTANTS (MICASPERPT (FQUOTIENT 2540 72)) (IHALFMICASPERPT 17) (IMICASPERPT 35)) (DEFMACRO \\MICASTOPTS (MICAS) (COND ((NUMBERP MICAS) (QUOTIENT MICAS MICASPERPT)) (T (BQUOTE ( QUOTIENT (\\\, MICAS) MICASPERPT))))) (PUTPROP (QUOTE HARDCOPY) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 22:15:08")) (FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT) (PUTPROP (QUOTE CMLARRAY) (QUOTE IMPORTDATE) (IDATE " 6-Jan-1993 12:21:21")) (RPAQQ \\MISCN-TABLE-LIST ((USER-SUBR 0 \\USER-SUBR-UFN T) (CL:VALUES 1 CL::VALUES-UFN NIL) (CL:SXHASH 2 CL::SXHASH-UFN NIL) (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL) (STRINGHASHBITS 4 \\STRINGHASHBITS-UFN NIL) (STRING-EQUAL-HASHBITS 5 \\STRING-EQUAL-HASHBITS-UFN NIL) (CL:VALUES-LIST 6 CL::VALUES-LIST-UFN NIL) (|LCFetchMethod| 7 |LCFetchMethod| NIL) (|LCFetchMethodOrHelp| 8 NIL NIL) ( |LCFindVarIndex| 9 NIL NIL) (|LCGetIVValue| 10 NIL NIL) (|LCPutIVValue| 11 NIL NIL))) (RPAQQ \\USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN) (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN))) (RPAQQ \\INITSUBRS ((BACKGROUNDSUBR 6) (CHECKBCPLPASSWORD 7) (DISKPARTITION 8) (DSPBOUT 9) (DSPRATE 10 ) (GATHERSTATS 11) (GETPACKETBUFFER 12) (LISPFINISH 13) (MOREVMEMFILE 14) (RAID 15) (READRAWPBI 16) ( WRITERAWPBI 17) (SETSCREENCOLOR 18) (SHOWDISPLAY 19) (PUPLEVEL1STATE 20) (WRITESTATS 21) ( CONTEXTSWITCH 22) (COPYSYS0SUBR 23) (WRITEMAP 24) (UFS-GETFILENAME 34) (UFS-DELETEFILE 35) ( UFS-RENAMEFILE 36) (COM-READPAGES 37) (COM-WRITEPAGES 38) (COM-TRUNCATEFILE 39) (UFS-DIRECTORYNAMEP 41 ) (COM-GETFREEBLOCK 45) (SETUNIXTIME 48) (GETUNIXTIME 49) (COPYTIMESTATS 50) (UNIX-USERNAME 51) ( UNIX-FULLNAME 52) (UNIX-GETENV 53) (UNIX-GETPARM 54) (CHECK-SUM 55) (ETHER-SUSPEND 56) (ETHER-RESUME 57) (ETHER-AVAILABLE 58) (ETHER-RESET 59) (ETHER-GET 60) (ETHER-SEND 61) (ETHER-SETFILTER 62) ( ETHER-CHECK 63) (DSPCURSOR 64) (SETMOUSEXY 65) (DSP-VIDEOCOLOR 66) (DSP-SCREENWIDTH 67) ( DSP-SCREENHEIGHT 68) (BITBLTSUB 69) (BLTCHAR 70) (TEDIT.BLTCHAR 71) (BITBLT.BITMAP 72) ( BLTSHADE.BITMAP 73) (RS232C-CMD 74) (RS232C-READ-INIT 75) (RS232C-WRITE 76) (KEYBOARDBEEP 80) ( KEYBOARDMAP 81) (KEYBOARDSTATE 82) (VMEMSAVE 89) (LISP-FINISH 90) (NEWPAGE 91) (DORECLAIM 92) ( DUMMY-135Q 93) (NATIVE-MEMORY-REFERENCE 94) (OLD-COMPILE-LOAD-NATIVE 95) (DISABLEGC 96) ( COM-SETFILEINFO 103) (COM-OPENFILE 104) (COM-CLOSEFILE 105) (DSK-GETFILENAME 106) (DSK-DELETEFILE 107) (DSK-RENAMEFILE 108) (COM-NEXT-FILE 110) (COM-FINISH-FINFO 111) (COM-GEN-FILES 112) ( DSK-DIRECTORYNAMEP 113) (COM-GETFILEINFO 114) (COM-CHANGEDIR 116) (UNIX-HANDLECOMM 117) (RPC-CALL 119) (MESSAGE-READP 120) (MESSAGE-READ 121) (MONITOR-CONTROL 128) (GET-NATIVE-ADDR-FROM-LISP-PTR 131) ( GET-LISP-PTR-FROM-NATIVE-ADDR 132) (LOAD-NATIVE-FILE 133) (SUSPEND-LISP 134) (NEW-BLTCHAR 135) ( COLOR-INIT 136) (COLOR-SCREENMODE 137) (COLOR-MAP 138) (COLOR-BASE 139) (|C-SlowBltChar| 140) ( UNCOLORIZE-BITMAP 141) (COLORIZE-BITMAP 142) (COLOR-8BPPDRAWLINE 143) (TCP-OP 144) (WITH-SYMBOL 145) ( CAUSE-INTERRUPT 146) (OPEN-SOCKET 160) (CLOSE-SOCKET 161) (READ-SOCKET 162) (WRITE-SOCKET 163) ( CALL-C-FUNCTION 167) (DLD-LINK 168) (DLD-UNLINK-BY-FILE 169) (DLD-UNLINK-BY-SYMBOL 170) ( DLD-GET-SYMBOL 171) (DLD-GET-FUNC 172) (DLD-FUNCTION-EXECUTABLE-P 173) (DLD-LIST-UNDEFINED-SYMBOLS 174 ) (C-MALLOC 175) (C-FREE 176) (C-PUTBASEBYTE 177) (C-GETBASEBYTE 178) (CHAR-OPENFILE 200) (CHAR-BIN 201) (CHAR-BOUT 202) (CHAR-IOCTL 203) (CHAR-CLOSEFILE 204) (CHAR-EOFP 205) (CHAR-READP 206) (CHAR-BINS 207) (CHAR-BOUTS 208) (CHAR-FILLBUFFER 209))) (PUTPROP (QUOTE LLSUBRS) (QUOTE IMPORTDATE) (IDATE "17-Dec-1992 14:28:41")) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (LISPXPRIN1 "EXPORTS GATHERED FROM {DSK}larry>ilisp>medley>sources> ON 12-Feb-2021 19:12:25" T) (LISPXTERPRI T) (PUTPROP (QUOTE FILESETS) (QUOTE IMPORTDATE) (IDATE "12-Feb-2021 18:10:20")) (RPAQQ MODARITHMACROS (CEIL FLOOR FOLDHI FOLDLO MODUP UNFOLD MOD)) (PUTPROPS CEIL MACRO ((X N) (FLOOR (IPLUS X (CONSTANT (SUB1 N))) N))) (PUTPROPS FLOOR MACRO ((X N) (LOGAND X (CONSTANT (LOGXOR (SUB1 N) -1))))) (PUTPROPS FOLDHI MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR ( AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) (LIST (QUOTE IPLUS) FORM (SUB1 DIVISOR)) (SUB1 (INTEGERLENGTH DIVISOR))))))) (PUTPROPS FOLDLO MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR ( AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) FORM (SUB1 ( INTEGERLENGTH DIVISOR))))))) (PUTPROPS MODUP MACRO (OPENLAMBDA (X N) (IDIFFERENCE (SUB1 N) (IMOD (SUB1 X) N)))) (PUTPROPS UNFOLD MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR ( AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LLSH) FORM (SUB1 ( INTEGERLENGTH DIVISOR))))))) (PUTPROPS MOD MACRO (= . IMOD)) (RPAQQ BITSPERNIBBLE 4) (RPAQQ NIBBLESPERBYTE 2) (RPAQQ BITSPERBYTE 8) (RPAQQ BITSPERCELL 32) (RPAQQ BITSPERWORD 16) (RPAQQ BYTESPERCELL 4) (RPAQQ BYTESPERPAGE 512) (RPAQQ BYTESPERWORD 2) (RPAQQ CELLSPERPAGE 128) (RPAQQ CELLSPERSEGMENT 32768) (RPAQQ PAGESPERSEGMENT 256) (RPAQQ WORDSPERCELL 2) (RPAQQ WORDSPERPAGE 256) (RPAQQ WORDSPERSEGMENT 65536) (RPAQQ WORDSPERQUAD 4) (RPAQQ CELLSPERQUAD 2) (RPAQQ BYTESPERQUAD 8) (CONSTANTS BITSPERNIBBLE NIBBLESPERBYTE BITSPERBYTE BITSPERCELL BITSPERWORD BYTESPERCELL BYTESPERPAGE BYTESPERWORD CELLSPERPAGE CELLSPERSEGMENT PAGESPERSEGMENT WORDSPERCELL WORDSPERPAGE WORDSPERSEGMENT WORDSPERQUAD CELLSPERQUAD BYTESPERQUAD) (RPAQQ INTEGERSIZECONSTANTS ((BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP )) (MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP ( IDIFFERENCE -1 MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP ( LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 MAX.FIXP)))) (RPAQ BITS.PER.SMALLP (ADD1 BITSPERWORD)) (RPAQ SMALLP.LENGTH (SUB1 BITS.PER.SMALLP)) (RPAQ MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (RPAQ MIN.SMALLP (IDIFFERENCE -1 MAX.SMALLP)) (RPAQ BITS.PER.FIXP BITSPERCELL) (RPAQ FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (RPAQ MAX.FIXP (LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (RPAQ MIN.FIXP (IDIFFERENCE -1 MAX.FIXP)) (CONSTANTS (BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP)) (MAX.SMALLP ( LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP (IDIFFERENCE -1 MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP (LOGOR (LSH 1 ( SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 MAX.FIXP))) (PUTPROP (QUOTE MODARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:46:21")) (RPAQQ WINDFLG T) (CONSTANTS (WINDFLG T)) (RPAQQ INITCONSTANTS ((* |;;;| "(LISPNAME VALUE BCPLNAME UCODENAME)") (CDRCODING 1 T T) (* \; "IF CDRCODING=0, CDR CODING IS OFF, OTHERWISE ON") (* |;;| "type numbers -- repeated on LLBASIC too") (\\SMALLP 1 SMALLTYPE |SmallType|) (\\FIXP 2 INTEGERTYPE |FixpType|) (\\FLOATP 3 FLTPTTYPE |FloatpType|) (\\LITATOM 4 ATOMTYPE |AtomType|) (\\LISTP 5 LISTTYPE |ListType|) (\\ARRAYP 6 ARRAYPTRTYPE |ArrayType|) (\\STRINGP 7 STRINGPTRTYPE) (\\STACKP 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10 NIL |VMemPagePType|) (\\STREAM 11 NIL STREAMTYPE) (* |;;| "TYPE TABLE CONSTANTS - - - - - - - - - - - - - - - - - - - - - -") (\\TT.TYPEMASK 2047 |TTTypeMask| T ) (\\TT.NOREF 32768 NIL T) (\\TT.SYMBOLP 16384 NIL T) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 2048) (* |;;| "page map - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -") (|\\PMblockSize| 32 PMBLOCKSIZE) (|\\STATSsize| 8 T) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535 T) ( |\\FirstVmemBlock| 2 T) (\\MAXVMPAGE 131069) (\\MAXVMSEGMENT 255) (* |;;| "interface page") ( |\\IFPValidKey| 5603 T) (* |;;| "MDS") (|\\FirstMDSPage| 32766) (* \; "Was 37776Q pre 16-meg intiial") (|\\MaxMDSPage| 524285) (|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512) (|\\PagesPerMDSUnit| 2) (* \; "(FOLDLO \\MDSIncrement WORDSPERPAGE)") (* |;;| "arrays") (\\ARRAYSPACE (46 0)) ( |\\FirstArraySegment| 46) (|\\FirstArrayPage| 11776) (\\ARRAYSPACE2 (64 0)) ( |\\DefaultSecondArrayPage| 32768) (* \; "Was 40000Q before 16meg initial") (* |;;| "stack block constants") (|\\StackMask| 57344 T T) (|\\FxtnBlock| 49152 T T) (|\\GuardBlock| 57344 T T ) (|\\BFBlock| 32768 T T) (|\\FreeStackBlock| 40960 T T) (|\\NotStackBlock| 0) (* \; "none of the above") (|\\MinExtraStackWords| 32 T T) (* |;;| "backspace kludge") (ERASECHARCODE 0 T) ( * |;;| "GC constants") (\\HT1CNT 1024 NIL T) (\\HTSTKBIT 512 NIL T) (\\HTCNTMASK 64512 NIL T) ( \\HTMAINSIZE 65536 NIL T) (\\HTCOLLSIZE 1048576 NIL T) (* \; "HTCOLL size in words") (\\HTENDFREE 1 NIL T) (\\HTFREEPTR 0 NIL T) (* |;;| "pointers and lengths of various data spaces") (\\ATOMSPACE (0 0) (|ATOMspace| NIL) (|atomHiVal| NIL)) (|\\AtomHI| 0) (\\CHARHI 7) (* \; "overlap character space and the atom hash table space") (|\\AtomHashTable| (21 0) (|AHTspace| |AHTbase|)) (|\\AtomHTpages| 256 AHTSIZE) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) ( \\SMALLPOSPSPACE (14 0)) (|\\SmallPosHi| 14 |SMALLPOSspace| |smallpl|) (\\SMALLNEGSPACE (15 0)) ( |\\SmallNegHi| 15 |SMALLNEGspace| |smallneg|) (|\\NumSmallPages| 512) (* |;;| "PNAME SPACEin the old world; used for initial atoms now.") (\\PNPSPACE (8 0) (|PNPspace| |PNPbase|)) (\\PNAME.HI 8) (\\OLDATOMSPACE (44 0)) (* \; "NEW ATOM SPACE") (\\ATOM.HI 44) (* \; "HI PART OF NEW ATOM SPACE") (* |;;| "Definitions in old atom world") (\\DEFSPACE (10 0) (|DEFspace| |DEFbase|) (|DEFspace| |DEFbase|)) (\\DEF.HI 10) (\\VALSPACE (12 0) (|TOPVALspace| |TOPVALbase|) ( |VALspace| |VALbase|)) (\\VAL.HI 12) (\\PLISTSPACE (2 0) (|PLISTspace| |PLISTbase|)) (\\PLIST.HI 2) ( \\PAGEMAP (5 0) (|PAGEMAPspace| |PAGEMAPbase|)) (|\\NumPageMapPages| 256) (|\\PageMapTBL| (20 512) ( |PMTspace| |PMTbase|)) (|\\InterfacePage| (20 0) (|INTERFACEspace| |INTERFACEbase|) (|INTERFACEspace| |INTERFACEbase|)) (\\IOPAGE (0 65280)) (|\\DoveIORegion| (0 16384)) (\\IOCBPAGE (0 256)) (\\FPTOVP (2 0)) (|\\MDSTypeTable| (24 0) (|MDSTYPEspace| |MDSTYPEbase|) (|MDSTYPEspace| |MDSTYPEbase|)) ( |\\MDSTTsize| 1024 T) (* \; "in Pages") (\\MISCSTATS (20 2560) (|STATSspace| |MISCSTATSbase|)) ( |\\UFNTable| (20 3072) NIL (|STATSspace| |UFNTablebase|)) (|\\UFNTableSize| 2) (|\\DTDSpaceBase| (20 4096) (|DTDspace| |DTDbase|) (|DTDspace| |DTDbase|)) (|\\DTDSize| 18 T) (\\LISTPDTD (20 4186)) ( |\\EndTypeNumber| 2047) (\\LOCKEDPAGETABLE (20 28672)) (|\\NumLPTPages| 16) (\\STACKSPACE (1 0) ( |STACKspace| NIL) (|STACKspace| NIL)) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 1 T T) (\\HTMAIN (22 0) (|HTMAINspace| |HTMAINbase|) (|HTMAINspace| |HTMAINbase|)) (|\\HTMAINnpages| 256 T) (\\HTOVERFLOW (23 0) NIL (NIL |HTOVERFLOWbase|)) (\\HTBIGCOUNT (23 32768)) (\\HTCOLL (28 0) NIL (|HTCOLLspace| |HTCOLLbase|)) (\\DISPLAYREGION (18 0)) (|\\D1BCPLspace| 0 T |LEmubrHiVal|) ( |\\D0BCPLspace| 0 T) (* |;;| "Interface Page locations") (|\\CurrentFXP| 0 T T) (|\\ResetFXP| 1 T T) ( |\\SubovFXP| 2 T T) (|\\KbdFXP| 3 T T) (|\\HardReturnFXP| 4 T T) (\\GCFXP 5) (\\FAULTFXP 6 T T) ( |\\MiscFXP| 14 T T) (|\\TeleRaidFXP| 24 T T) (* |;;| "emulator segment locations") (DCB.EM 272) ( DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (KBDAD1.EM 65053) (KBDAD2.EM 65054) ( KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) ( |\\LispKeyMask| 8192 T T) (|\\BcplKeyMask| 4352 T T) (* \; "Machine types") (\\MAIKO 3) (\\DOLPHIN 4) (\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (* |;;| "FOR DLION (AND DAYBREAK)") (\\VP.DISPLAY 4608) ( \\NP.DISPLAY 202) (* \; "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)") ( \\NP.WIDEDOVEDISPLAY 243) (* \; "Wide Dove display 1152x864 pixels") (\\WIDEDOVEDISPLAYWIDTH 1152) ( \\RP.AFTERDISPLAY 206) (* \; "Includes 4 pages for cursor") (\\RP.AFTERDOVEDISPLAY 243) (* \; "if big screen") (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (* \; "(+ \\RP.TEMPDISPLAY \\NP.WIDEDOVEDISPLAY)") (\\RP.STACK 768) (\\VP.STACK 256) (\\RP.MAP 256) ( \\NP.MAP 256) (\\RP.IOPAGE 512) (* \; "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range") (\\RP.DOVEIOCBPAGE 543) ( \\RP.DOVEIORGN 544) (\\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 5120) ( \\VP.FPTOVP 512) (\\NP.FPTOVP 4096) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 6144) ( \\NP.TYPETABLE 1024) (\\RP.TYPETABLE 5120) (\\VP.GCTABLE 5632) (\\NP.GCTABLE 256) (\\RP.GCTABLE 6144) (\\VP.GCOVERFLOW 5888) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 6400) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) ( \\VP.PRIMARYMAP 5122) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 5232) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) ( \\VP.BUFFERS 218) (* \; "DLion processor commands") (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) ( \\DL.READTOD 32770) (\\DL.READPID 32771) (\\DL.BOOTBUTTON 32772))) (RPAQQ MISCSTATSLAYOUT ((STARTTIME FIXP |MSstrtTime|) (TOTALTIME FIXP) (SWAPWAITTIME FIXP T) ( PAGEFAULTS FIXP T) (SWAPWRITES FIXP T) (DISKIOTIME FIXP T) (DISKOPS FIXP T) (KEYBOARDWAITTIME FIXP T) (GCTIME FIXP T) (NETIOTIME FIXP T) (NETIOOPS FIXP T) (SWAPTEMP0 FIXP) (SWAPTEMP1 FIXP) (RCLKSECOND FIXP) (SECONDSCLOCK FIXP) (MILLISECONDSCLOCK FIXP) (BASECLOCK FIXP) (RCLKTEMP0 FIXP) (SECONDSTMP FIXP) (MILLISECONDSTMP FIXP) (BASETMP FIXP) (EXCESSTIMETMP FIXP) (CLOCKTEMP0 FIXP) (DISKTEMP0 FIXP) ( DISKTEMP1 FIXP) (TELERAIDTEMP1 FIXP) (TELERAIDTEMP2 FIXP) (TELERAIDTEMP3 FIXP) (LASTUSERACTION FIXP) ( DLMOUSETIMER FIXP) (DLMOUSETEMP FIXP))) (RPAQQ IFPAGELAYOUT ((|CurrentFXP| WORD) (* \; "First 7 items are FX values for user and 6 system contexts.") (|ResetFXP| WORD) (|SubovFXP| WORD) ( |KbdFXP| WORD) (|HardReturnFXP| WORD) (GCFXP WORD) (FAULTFXP WORD) (|EndOfStack| WORD) (* \; "Stack high-water mark: address of guard block at current end of stack") (|LVersion| WORD) (* \; "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp") ( |MinRVersion| WORD) (|MinBVersion| WORD) (|RVersion| WORD) (* \; "Bcpl fills in the actual microcode, Bcpl versions.") (|BVersion| WORD) (|MachineType| WORD) ( |MiscFXP| WORD) (* \; "FX for MISC context") (|Key| WORD) (* \; "= IFPValidKey if vmem consistent.") ( |SerialNumber| WORD) (* \; "Pup host number (Dorado/Dolphin)") (|EmulatorSpace| WORD) (* \; "Hiloc of bcpl space (always zero now)") (|ScreenWidth| WORD) (|NxtPMAddr| WORD) (* \; "Next page to be allocated in secondary page map table") (|NActivePages| WORD) (* \; "Length of vmem in use") (|NDirtyPages| WORD) (* \; "not used, but maintained as = NActivePages") ( |filePnPMP0| WORD) (* \; "Sysout page number of first page of secondary page map table (\\PAGEMAP), which is where the secondary map pages themselves live" ) (|filePnPMT0| WORD) (* \; "Sysout page number of first page of primary page map table") (TELERAIDFXP WORD) (* \; "FX for TeleRaid server context") (NATIVE-START-MEM-PAGE WORD) (* \; "Unix page where native code starts") (NATIVE-LENGTH-PAGE WORD) (* \; "Unix page length of native code") (NATIVE-PAGE-OFFSET WORD) (* \; "Lisp Disk Page offset of native code") (|UserNameAddr| WORD) (* \; "Addresses in bcpl space (seg 0) of global user name and password") (|UserPswdAddr| WORD) (|StackBase| WORD) (* \; "Stack address where user stack starts") (FAULTHI WORD) (* \; "Microcode for page fault stores fault address here, then does context switch to FAULTFXP") (FAULTLO WORD) (DEVCONFIG WORD) (* \; "IT'S FOR KB,DISP TYPE") (* \; "Formerly REALPAGETABLE, back when it was always in Bcpl space.") (RPTSIZE WORD) (* \; "Number of entries in Real Page Table") (RPOFFSET WORD) (* \; "RP-RPOFFSET => index in table") ( MAXETHERBYTES WORD) (* \; "Number of bytes available in a pbi, not counting encapsulation (Dorado)") ( EMBUFVP WORD) (* \; "VP of a one-page emulator buffer") (|NSHost0| WORD) (* \; "Machine's 48-bit NS host number. Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in." ) (|NSHost1| WORD) (|NSHost2| WORD) (|MDSZone| WORD) (* \; "Obsolete -- was used by Dolphin 10MB network code.") (|MDSZoneLength| WORD) (EMUBUFFERS WORD) (* \; "Buffer space in segment 0 for swapping/disk activity") (EMUBUFLENGTH WORD) (* \; "Number of words of said space") (LASTNUMCHARS WORD) (* \; "No longer used?") (SYSDISK WORD) (* \; "Address of sysDisk in Bcpl space -- disk obj for boot partition.") (ISFMAP WORD) (* |;;| "The following 4 are for \\MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!" ) (MISCSTACKFN FULLXPOINTER) (MISCSTACKARG1 FULLXPOINTER) (MISCSTACKARG2 FULLXPOINTER) ( MISCSTACKRESULT FULLXPOINTER) (|NRealPages| WORD) (* \; "Number pages of real memory") ( |LastLockedFilePage| WORD) (* \; "Last page of vmem that is locked--booting has to load at least that far.") (|LastDominoFilePage| WORD ) (* \; "Last sysout page reserved for Dandelion microcode") (|FPTOVPStart| WORD) (* \; "Sysout page where FPTOVP starts") (FAKEMOUSEBITS WORD) (* \; "Used to implement fake middle button on 2-button Dandelion.") (|DL24BitAddressable| WORD) (* \; "non-zero if DLion capable of addressing 32MB virtual memory") (REALPAGETABLEPTR FULLXPOINTER) (* \; "Address of real page table, set up by Bcpl (but not chained together)") (|DLLastVmemPage| WORD) (* \; "DLion booting microcode puts length of vmem file here.") (|FullSpaceUsed| WORD) (* \; "Non-zero if vmem beyond initial 8MB has been allocated.") (FAKEKBDAD4 WORD) (FAKEKBDAD5 WORD) (* |;;| "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with." ) (|XVmemFmapBase| WORD) (* \; "Bcpl stores isf map pointer to each partition here. First is redundant with ISFMAP field above.") ( NIL WORD) (NIL WORD) (|XVmemFmapHighBase| WORD) (* \; "Bcpl stores the highest vm page contained in this or earlier partition.") (NIL WORD) (NIL WORD) ( |XVmemDiskBase| FULLXPOINTER) (* \; "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).") (NIL FULLXPOINTER) (NIL FULLXPOINTER))) (RPAQQ MAIKO.IFPAGELAYOUT ((|CurrentFXP| WORD) (* \; "First 7 items are FX values for user and 6 system contexts.") (|ResetFXP| WORD) (|SubovFXP| WORD) ( |KbdFXP| WORD) (|HardReturnFXP| WORD) (GCFXP WORD) (FAULTFXP WORD) (|EndOfStack| WORD) (* \; "Stack high-water mark: address of guard block at current end of stack") (|LVersion| WORD) (* \; "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp") ( |MinRVersion| WORD) (|MinBVersion| WORD) (|RVersion| WORD) (* \; "Bcpl fills in the actual microcode, Bcpl versions.") (|BVersion| WORD) (|MachineType| WORD) ( |MiscFXP| WORD) (* \; "FX for MISC context") (|Key| WORD) (* \; "= IFPValidKey if vmem consistent.") ( |SerialNumber| WORD) (* \; "Pup host number (Dorado/Dolphin)") (|EmulatorSpace| WORD) (* \; "Hiloc of bcpl space (always zero now)") (|ScreenWidth| WORD) (|NxtPMAddr| WORD) (* \; "Next page to be allocated in secondary page map table") (NIL WORD) (* \; "WAS NActivePages, Length of vmem in use") (NIL WORD) (* \; "WAS NDirtyPages, not used, but maintained as = NActivePages") (|filePnPMP0| WORD) (* \; "Sysout page number of first page of secondary page map table (\\PAGEMAP), which is where the secondary map pages themselves live" ) (|filePnPMT0| WORD) (* \; "Sysout page number of first page of primary page map table") (TELERAIDFXP WORD) (* \; "FX for TeleRaid server context") (NATIVE-START-MEM-PAGE WORD) (* \; "Unix page where native code starts") (NATIVE-LENGTH-PAGE WORD) (* \; "Unix page length of native code") (NATIVE-PAGE-OFFSET WORD) (* \; "Lisp Disk Page offset of native code") (|UserNameAddr| WORD) (* \; "Addresses in bcpl space (seg 0) of global user name and password") (|UserPswdAddr| WORD) (|StackBase| WORD) (* \; "Stack address where user stack starts") (FAULTHI WORD) (* \; "Microcode for page fault stores fault address here, then does context switch to FAULTFXP") (FAULTLO WORD) (DEVCONFIG WORD) (* \; "IT'S FOR KB,DISP TYPE") (* \; "Formerly REALPAGETABLE, back when it was always in Bcpl space.") (RPTSIZE WORD) (* \; "Number of entries in Real Page Table") (RPOFFSET WORD) (* \; "RP-RPOFFSET => index in table") ( MAXETHERBYTES WORD) (* \; "Number of bytes available in a pbi, not counting encapsulation (Dorado)") ( EMBUFVP WORD) (* \; "VP of a one-page emulator buffer") (|NSHost0| WORD) (* \; "Machine's 48-bit NS host number. Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in." ) (|NSHost1| WORD) (|NSHost2| WORD) (|MDSZone| WORD) (* \; "Obsolete -- was used by Dolphin 10MB network code.") (|MDSZoneLength| WORD) (EMUBUFFERS WORD) (* \; "Buffer space in segment 0 for swapping/disk activity") (EMUBUFLENGTH WORD) (* \; "Number of words of said space") (* |;;| "The following 2 are available if NEW_STOARGE is specified in C") (|ProcessSize| WORD) (* \; "Process size for which can be use as LISP space") (|StorageFullState| WORD) (* \; "Save last storage state") (ISFMAP WORD) (* |;;| "The following 4 are for \\MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!" ) (MISCSTACKFN FULLXPOINTER) (MISCSTACKARG1 FULLXPOINTER) (MISCSTACKARG2 FULLXPOINTER) ( MISCSTACKRESULT FULLXPOINTER) (|NRealPages| WORD) (* \; "Number pages of real memory") ( |LastLockedFilePage| WORD) (* \; "Last page of vmem that is locked--booting has to load at least that far.") (|LastDominoFilePage| WORD ) (* \; "Last sysout page reserved for Dandelion microcode") (|FPTOVPStart| WORD) (* \; "Sysout page where FPTOVP starts") (FAKEMOUSEBITS WORD) (* \; "Used to implement fake middle button on 2-button Dandelion.") (|DL24BitAddressable| WORD) (* \; "non-zero if DLion capable of addressing 32MB virtual memory") (REALPAGETABLEPTR FULLXPOINTER) (* \; "Address of real page table, set up by Bcpl (but not chained together)") (SYSDISK WORD) (* \; "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.") (|FullSpaceUsed| WORD) ( * \; "Non-zero if vmem beyond initial 8MB has been allocated.") (FAKEKBDAD4 WORD) (FAKEKBDAD5 WORD) (* |;;| "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with." ) (|XVmemFmapBase| WORD) (* \; "Bcpl stores isf map pointer to each partition here. First is redundant with ISFMAP field above.") ( NIL WORD) (NIL WORD) (|XVmemFmapHighBase| WORD) (* \; "Bcpl stores the highest vm page contained in this or earlier partition.") (NIL WORD) (NIL WORD) ( |XVmemDiskBase| FULLXPOINTER) (* \; "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).") (NIL FULLXPOINTER) (NIL FULLXPOINTER) (|DLLastVmemPage| FIXP) (* \; "DLion booting microcode puts length of vmem file here.") (|NActivePages| FIXP) (* \; "Length of vmem in use") (|NDirtyPages| FIXP) (* \; "not used, but maintained as = NActivePages"))) (RPAQQ IOPAGELAYOUT ((NIL 18 WORD) (DLMAINTPANEL WORD NIL T) (DLFLOPPYCMD WORD) (DLTTYPORTCMD WORD) ( DLPROCESSORCMD WORD) (NEWMOUSESTATE WORD) (DLBEEPCMD WORD) (DLRS232CMISCCOMMAND WORD) (DLRS232CPUTFLAG WORD) (DLRS232CGETFLAG WORD) (NIL 6 WORD) (DLFLOPPY WORD) (DLTTYOUT WORD) (NIL 1 WORD) (DLTTYIN WORD) (NIL 1 WORD) (DLPROCESSOR2 WORD) (DLPROCESSOR1 WORD) (DLPROCESSOR0 WORD) (NEWMOUSEX WORD) (NEWMOUSEY WORD) (DLBEEPFREQ WORD) (DLRS232CPARAMETERCSBLO WORD) (DLRS232CPARAMETERCSBHI WORD) ( DLRS232CSETRS366STATUS 3 WORD) (DLRS232CPUTCSBLO WORD) (DLRS232CPUTCSBHI WORD) (DLRS232CGETCSBLO WORD) (DLRS232CGETCSBHI WORD) (DLRS232CDEVICESTATUS WORD) (DLRS232CPARAMETEROUTCOME WORD) (DLTODVALID WORD) (DLTODLO WORD NIL T) (DLTODHI WORD) (DLTODLO2 WORD) (DLMOUSEX WORD NIL T) (DLMOUSEY WORD NIL T) ( DLUTILIN WORD NIL T) (DLKBDAD0 WORD NIL T) (DLKBDAD1 WORD NIL T) (DLKBDAD2 WORD NIL T) (DLKBDAD3 WORD NIL T) (DLKBDAD4 WORD NIL T) (DLKBDAD5 WORD NIL T) (DLLSEPIMAGECSB 32 WORD) (DLIOPHARDWARECONFIG WORD) (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) (DLRS232CPARAMETERCSBHI.11 WORD) ( DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) (DLETHERNET 12 WORD NIL T) (NIL 31 WORD) (DLDISPINTERRUPT WORD NIL T) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) (DLCURSORX WORD NIL T) ( DLCURSORY WORD NIL T) (DLCURSORBITMAP 16 WORD NIL T))) (RPAQQ CDRCODING 1) (RPAQQ \\SMALLP 1) (RPAQQ \\FIXP 2) (RPAQQ \\FLOATP 3) (RPAQQ \\LITATOM 4) (RPAQQ \\LISTP 5) (RPAQQ \\ARRAYP 6) (RPAQQ \\STRINGP 7) (RPAQQ \\STACKP 8) (RPAQQ \\CHARACTERP 9) (RPAQQ \\VMEMPAGEP 10) (RPAQQ \\STREAM 11) (RPAQQ \\TT.TYPEMASK 2047) (RPAQQ \\TT.NOREF 32768) (RPAQQ \\TT.SYMBOLP 16384) (RPAQQ \\TT.FIXP 8192) (RPAQQ \\TT.NUMBERP 4096) (RPAQQ \\TT.ATOM 2048) (RPAQQ |\\PMblockSize| 32) (RPAQQ |\\STATSsize| 8) (RPAQQ |\\NumPMTpages| 8) (RPAQQ |\\EmptyPMTEntry| 65535) (RPAQQ |\\FirstVmemBlock| 2) (RPAQQ \\MAXVMPAGE 131069) (RPAQQ \\MAXVMSEGMENT 255) (RPAQQ |\\IFPValidKey| 5603) (RPAQQ |\\FirstMDSPage| 32766) (RPAQQ |\\MaxMDSPage| 524285) (RPAQQ |\\DefaultSecondMDSPage| 65532) (RPAQQ |\\MDSIncrement| 512) (RPAQQ |\\PagesPerMDSUnit| 2) (RPAQQ |\\FirstArraySegment| 46) (RPAQQ |\\FirstArrayPage| 11776) (RPAQQ |\\DefaultSecondArrayPage| 32768) (RPAQQ |\\StackMask| 57344) (RPAQQ |\\FxtnBlock| 49152) (RPAQQ |\\GuardBlock| 57344) (RPAQQ |\\BFBlock| 32768) (RPAQQ |\\FreeStackBlock| 40960) (RPAQQ |\\NotStackBlock| 0) (RPAQQ |\\MinExtraStackWords| 32) (RPAQQ ERASECHARCODE 0) (RPAQQ \\HT1CNT 1024) (RPAQQ \\HTSTKBIT 512) (RPAQQ \\HTCNTMASK 64512) (RPAQQ \\HTMAINSIZE 65536) (RPAQQ \\HTCOLLSIZE 1048576) (RPAQQ \\HTENDFREE 1) (RPAQQ \\HTFREEPTR 0) (RPAQQ |\\AtomHI| 0) (RPAQQ \\CHARHI 7) (RPAQQ |\\AtomHTpages| 256) (RPAQQ |\\LastAtomPage| 255) (RPAQQ |\\MaxAtomFrLst| 65535) (RPAQQ |\\SmallPosHi| 14) (RPAQQ |\\SmallNegHi| 15) (RPAQQ |\\NumSmallPages| 512) (RPAQQ \\PNAME.HI 8) (RPAQQ \\ATOM.HI 44) (RPAQQ \\DEF.HI 10) (RPAQQ \\VAL.HI 12) (RPAQQ \\PLIST.HI 2) (RPAQQ |\\NumPageMapPages| 256) (RPAQQ |\\MDSTTsize| 1024) (RPAQQ |\\UFNTableSize| 2) (RPAQQ |\\DTDSize| 18) (RPAQQ |\\EndTypeNumber| 2047) (RPAQQ |\\NumLPTPages| 16) (RPAQQ |\\GuardStackAddr| 61440) (RPAQQ |\\LastStackAddr| 65534) (RPAQQ \\STACKHI 1) (RPAQQ |\\HTMAINnpages| 256) (RPAQQ |\\D1BCPLspace| 0) (RPAQQ |\\D0BCPLspace| 0) (RPAQQ |\\CurrentFXP| 0) (RPAQQ |\\ResetFXP| 1) (RPAQQ |\\SubovFXP| 2) (RPAQQ |\\KbdFXP| 3) (RPAQQ |\\HardReturnFXP| 4) (RPAQQ \\GCFXP 5) (RPAQQ \\FAULTFXP 6) (RPAQQ |\\MiscFXP| 14) (RPAQQ |\\TeleRaidFXP| 24) (RPAQQ DCB.EM 272) (RPAQQ DISPINTERRUPT.EM 273) (RPAQQ CURSORBITMAP.EM 281) (RPAQQ KBDAD0.EM 65052) (RPAQQ KBDAD1.EM 65053) (RPAQQ KBDAD2.EM 65054) (RPAQQ KBDAD3.EM 65055) (RPAQQ UTILIN.EM 65048) (RPAQQ CURSORX.EM 278) (RPAQQ CURSORY.EM 279) (RPAQQ MOUSEX.EM 276) (RPAQQ MOUSEY.EM 277) (RPAQQ |\\LispKeyMask| 8192) (RPAQQ |\\BcplKeyMask| 4352) (RPAQQ \\MAIKO 3) (RPAQQ \\DOLPHIN 4) (RPAQQ \\DORADO 5) (RPAQQ \\DANDELION 6) (RPAQQ \\DAYBREAK 8) (RPAQQ \\VP.DISPLAY 4608) (RPAQQ \\NP.DISPLAY 202) (RPAQQ \\NP.WIDEDOVEDISPLAY 243) (RPAQQ \\WIDEDOVEDISPLAYWIDTH 1152) (RPAQQ \\RP.AFTERDISPLAY 206) (RPAQQ \\RP.AFTERDOVEDISPLAY 243) (RPAQQ \\RP.DISPLAY 0) (RPAQQ \\RP.TEMPDISPLAY 2561) (RPAQQ \\RP.MISCLOCKED 2804) (RPAQQ \\RP.STACK 768) (RPAQQ \\VP.STACK 256) (RPAQQ \\RP.MAP 256) (RPAQQ \\NP.MAP 256) (RPAQQ \\RP.IOPAGE 512) (RPAQQ \\RP.DOVEIOCBPAGE 543) (RPAQQ \\RP.DOVEIORGN 544) (RPAQQ \\VP.DOVEIORGN 64) (RPAQQ \\DOVEIORGNSIZE 64) (RPAQQ \\VP.IOPAGE 255) (RPAQQ \\VP.IFPAGE 5120) (RPAQQ \\VP.FPTOVP 512) (RPAQQ \\NP.FPTOVP 4096) (RPAQQ \\RP.FPTOVP 1024) (RPAQQ \\RP.STARTBUFFERS 640) (RPAQQ \\VP.TYPETABLE 6144) (RPAQQ \\NP.TYPETABLE 1024) (RPAQQ \\RP.TYPETABLE 5120) (RPAQQ \\VP.GCTABLE 5632) (RPAQQ \\NP.GCTABLE 256) (RPAQQ \\RP.GCTABLE 6144) (RPAQQ \\VP.GCOVERFLOW 5888) (RPAQQ \\NP.GCOVERFLOW 1) (RPAQQ \\RP.GCOVERFLOW 6400) (RPAQQ \\FP.IFPAGE 2) (RPAQQ \\VP.IOCBS 1) (RPAQQ \\VP.PRIMARYMAP 5122) (RPAQQ \\VP.SECONDARYMAP 1280) (RPAQQ \\VP.LPT 5232) (RPAQQ \\VP.INITSCRATCH 8) (RPAQQ \\VP.RPT 128) (RPAQQ \\VP.BUFFERS 218) (RPAQQ \\DL.PROCESSORBUSY 32768) (RPAQQ \\DL.SETTOD 32769) (RPAQQ \\DL.READTOD 32770) (RPAQQ \\DL.READPID 32771) (RPAQQ \\DL.BOOTBUTTON 32772) (CONSTANTS (CDRCODING 1) (\\SMALLP 1) (\\FIXP 2) (\\FLOATP 3) (\\LITATOM 4) (\\LISTP 5) (\\ARRAYP 6) ( \\STRINGP 7) (\\STACKP 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10) (\\STREAM 11) (\\TT.TYPEMASK 2047) ( \\TT.NOREF 32768) (\\TT.SYMBOLP 16384) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 2048) ( |\\PMblockSize| 32) (|\\STATSsize| 8) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535) ( |\\FirstVmemBlock| 2) (\\MAXVMPAGE 131069) (\\MAXVMSEGMENT 255) (|\\IFPValidKey| 5603) ( |\\FirstMDSPage| 32766) (|\\MaxMDSPage| 524285) (|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512 ) (|\\PagesPerMDSUnit| 2) (|\\FirstArraySegment| 46) (|\\FirstArrayPage| 11776) ( |\\DefaultSecondArrayPage| 32768) (|\\StackMask| 57344) (|\\FxtnBlock| 49152) (|\\GuardBlock| 57344) ( |\\BFBlock| 32768) (|\\FreeStackBlock| 40960) (|\\NotStackBlock| 0) (|\\MinExtraStackWords| 32) ( ERASECHARCODE 0) (\\HT1CNT 1024) (\\HTSTKBIT 512) (\\HTCNTMASK 64512) (\\HTMAINSIZE 65536) ( \\HTCOLLSIZE 1048576) (\\HTENDFREE 1) (\\HTFREEPTR 0) (|\\AtomHI| 0) (\\CHARHI 7) (|\\AtomHTpages| 256 ) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) (|\\SmallPosHi| 14) (|\\SmallNegHi| 15) ( |\\NumSmallPages| 512) (\\PNAME.HI 8) (\\ATOM.HI 44) (\\DEF.HI 10) (\\VAL.HI 12) (\\PLIST.HI 2) ( |\\NumPageMapPages| 256) (|\\MDSTTsize| 1024) (|\\UFNTableSize| 2) (|\\DTDSize| 18) (|\\EndTypeNumber| 2047) (|\\NumLPTPages| 16) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 1) ( |\\HTMAINnpages| 256) (|\\D1BCPLspace| 0) (|\\D0BCPLspace| 0) (|\\CurrentFXP| 0) (|\\ResetFXP| 1) ( |\\SubovFXP| 2) (|\\KbdFXP| 3) (|\\HardReturnFXP| 4) (\\GCFXP 5) (\\FAULTFXP 6) (|\\MiscFXP| 14) ( |\\TeleRaidFXP| 24) (DCB.EM 272) (DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) ( KBDAD1.EM 65053) (KBDAD2.EM 65054) (KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) (|\\LispKeyMask| 8192) (|\\BcplKeyMask| 4352) (\\MAIKO 3) ( \\DOLPHIN 4) (\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (\\VP.DISPLAY 4608) (\\NP.DISPLAY 202) ( \\NP.WIDEDOVEDISPLAY 243) (\\WIDEDOVEDISPLAYWIDTH 1152) (\\RP.AFTERDISPLAY 206) (\\RP.AFTERDOVEDISPLAY 243) (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (\\RP.STACK 768) (\\VP.STACK 256 ) (\\RP.MAP 256) (\\NP.MAP 256) (\\RP.IOPAGE 512) (\\RP.DOVEIOCBPAGE 543) (\\RP.DOVEIORGN 544) ( \\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 5120) (\\VP.FPTOVP 512) ( \\NP.FPTOVP 4096) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 6144) (\\NP.TYPETABLE 1024) (\\RP.TYPETABLE 5120) (\\VP.GCTABLE 5632) (\\NP.GCTABLE 256) (\\RP.GCTABLE 6144) ( \\VP.GCOVERFLOW 5888) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 6400) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) ( \\VP.PRIMARYMAP 5122) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 5232) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) ( \\VP.BUFFERS 218) (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) (\\DL.READTOD 32770) (\\DL.READPID 32771) (\\DL.BOOTBUTTON 32772)) (RPAQQ \\MPERRORS ((\\MP.OBSOLETEVMEM 1) (\\MP.INVALIDVMEM 2 "Vmem inconsistent at startup") ( \\MP.IOCBPAGE 3 "No place for IOCB page at startup") (\\MP.MOB 4 "Map out of bounds") ( \\MP.INVALIDADDR 5) (\\MP.INVALIDVP 6) (\\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain") (\\MP.SELECTLOOP 8 "Loop in \\SELECTREALPAGE") ( \\MP.NEWPAGE 9 "Attempt to allocate already existing page") (\\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page") (\\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another") (\\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box") (\\MP.RESIDENT 13 "Fault on resident page") (\\MP.STACKFAULT 14 "Fault on stack") (\\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") ( \\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code") (\\MP.STACKFULL 19) (\\MP.MDSFULL 20) (\\MP.UNKNOWN.UFN 21) ( \\MP.ATOMSFULL 22) (\\MP.PNAMESFULL 23) (\\MP.USECOUNTOVERFLOW 24) (\\MP.MDSFULLWARNING 25) ( \\MP.BADMDSFREELIST 26) (\\MP.BADARRAYBLOCK 27) (\\MP.BADDELETEBLOCK 28) (\\MP.BADARRAYRECLAIM 29) ( \\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") ( \\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\\MP.DELREF0 32) (\\MP.PROCERROR 33) (\\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\\MP.32MBINUSE 35) (\\MP.TOPUNWOUND 36 "Unexpected (RETTO T)") (\\MP.STACKRELEASED 37) (\\MP.FLUSHLOCKED 38) (\\MP.MAPNOTLOCKED 39) ( \\MP.UNLOCKINGMAP 40) (\\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\\MP.BADRUNTABLE 42 "Malformed run table for vmem file"))) (RPAQQ \\MP.OBSOLETEVMEM 1) (RPAQ \\MP.INVALIDVMEM 2 "Vmem inconsistent at startup") (RPAQ \\MP.IOCBPAGE 3 "No place for IOCB page at startup") (RPAQ \\MP.MOB 4 "Map out of bounds") (RPAQQ \\MP.INVALIDADDR 5) (RPAQQ \\MP.INVALIDVP 6) (RPAQ \\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain") (RPAQ \\MP.SELECTLOOP 8 "Loop in \\SELECTREALPAGE") (RPAQ \\MP.NEWPAGE 9 "Attempt to allocate already existing page") (RPAQ \\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page") (RPAQ \\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another") (RPAQ \\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box") (RPAQ \\MP.RESIDENT 13 "Fault on resident page") (RPAQ \\MP.STACKFAULT 14 "Fault on stack") (RPAQ \\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") (RPAQ \\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (RPAQ \\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code") (RPAQQ \\MP.STACKFULL 19) (RPAQQ \\MP.MDSFULL 20) (RPAQQ \\MP.UNKNOWN.UFN 21) (RPAQQ \\MP.ATOMSFULL 22) (RPAQQ \\MP.PNAMESFULL 23) (RPAQQ \\MP.USECOUNTOVERFLOW 24) (RPAQQ \\MP.MDSFULLWARNING 25) (RPAQQ \\MP.BADMDSFREELIST 26) (RPAQQ \\MP.BADARRAYBLOCK 27) (RPAQQ \\MP.BADDELETEBLOCK 28) (RPAQQ \\MP.BADARRAYRECLAIM 29) (RPAQ \\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") (RPAQ \\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (RPAQQ \\MP.DELREF0 32) (RPAQQ \\MP.PROCERROR 33) (RPAQ \\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (RPAQQ \\MP.32MBINUSE 35) (RPAQ \\MP.TOPUNWOUND 36 "Unexpected (RETTO T)") (RPAQQ \\MP.STACKRELEASED 37) (RPAQQ \\MP.FLUSHLOCKED 38) (RPAQQ \\MP.MAPNOTLOCKED 39) (RPAQQ \\MP.UNLOCKINGMAP 40) (RPAQ \\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (RPAQ \\MP.BADRUNTABLE 42 "Malformed run table for vmem file") (CONSTANTS (\\MP.OBSOLETEVMEM 1) (\\MP.INVALIDVMEM 2 "Vmem inconsistent at startup") (\\MP.IOCBPAGE 3 "No place for IOCB page at startup") (\\MP.MOB 4 "Map out of bounds") (\\MP.INVALIDADDR 5) ( \\MP.INVALIDVP 6) (\\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain") (\\MP.SELECTLOOP 8 "Loop in \\SELECTREALPAGE") (\\MP.NEWPAGE 9 "Attempt to allocate already existing page") ( \\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page") (\\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another") (\\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box") (\\MP.RESIDENT 13 "Fault on resident page") (\\MP.STACKFAULT 14 "Fault on stack") (\\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") ( \\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code") (\\MP.STACKFULL 19) (\\MP.MDSFULL 20) (\\MP.UNKNOWN.UFN 21) ( \\MP.ATOMSFULL 22) (\\MP.PNAMESFULL 23) (\\MP.USECOUNTOVERFLOW 24) (\\MP.MDSFULLWARNING 25) ( \\MP.BADMDSFREELIST 26) (\\MP.BADARRAYBLOCK 27) (\\MP.BADDELETEBLOCK 28) (\\MP.BADARRAYRECLAIM 29) ( \\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") ( \\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\\MP.DELREF0 32) (\\MP.PROCERROR 33) (\\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\\MP.32MBINUSE 35) (\\MP.TOPUNWOUND 36 "Unexpected (RETTO T)") (\\MP.STACKRELEASED 37) (\\MP.FLUSHLOCKED 38) (\\MP.MAPNOTLOCKED 39) ( \\MP.UNLOCKINGMAP 40) (\\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\\MP.BADRUNTABLE 42 "Malformed run table for vmem file")) (GLOBALVARS \\ARRAYSPACE \\ARRAYSPACE2 \\ATOMSPACE |\\AtomHashTable| \\SMALLPOSPSPACE \\SMALLNEGSPACE \\PNPSPACE \\OLDATOMSPACE \\DEFSPACE \\VALSPACE \\PLISTSPACE \\PAGEMAP |\\PageMapTBL| |\\InterfacePage| \\IOPAGE |\\DoveIORegion| \\IOCBPAGE \\FPTOVP |\\MDSTypeTable| \\MISCSTATS |\\UFNTable| |\\DTDSpaceBase| \\LISTPDTD \\LOCKEDPAGETABLE \\STACKSPACE \\HTMAIN \\HTOVERFLOW \\HTBIGCOUNT \\HTCOLL \\DISPLAYREGION) (BLOCKRECORD MISCSTATS ((STARTTIME FIXP) (TOTALTIME FIXP) (SWAPWAITTIME FIXP) (PAGEFAULTS FIXP) ( SWAPWRITES FIXP) (DISKIOTIME FIXP) (DISKOPS FIXP) (KEYBOARDWAITTIME FIXP) (GCTIME FIXP) (NETIOTIME FIXP) (NETIOOPS FIXP) (SWAPTEMP0 FIXP) (SWAPTEMP1 FIXP) (RCLKSECOND FIXP) (SECONDSCLOCK FIXP) ( MILLISECONDSCLOCK FIXP) (BASECLOCK FIXP) (RCLKTEMP0 FIXP) (SECONDSTMP FIXP) (MILLISECONDSTMP FIXP) ( BASETMP FIXP) (EXCESSTIMETMP FIXP) (CLOCKTEMP0 FIXP) (DISKTEMP0 FIXP) (DISKTEMP1 FIXP) (TELERAIDTEMP1 FIXP) (TELERAIDTEMP2 FIXP) (TELERAIDTEMP3 FIXP) (LASTUSERACTION FIXP) (DLMOUSETIMER FIXP) (DLMOUSETEMP FIXP)) (CREATE (\\ALLOCBLOCK 31))) (BLOCKRECORD IFPAGE ((|CurrentFXP| WORD) (* \; "First 7 items are FX values for user and 6 system contexts.") (|ResetFXP| WORD) (|SubovFXP| WORD) ( |KbdFXP| WORD) (|HardReturnFXP| WORD) (GCFXP WORD) (FAULTFXP WORD) (|EndOfStack| WORD) (* \; "Stack high-water mark: address of guard block at current end of stack") (|LVersion| WORD) (* \; "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp") ( |MinRVersion| WORD) (|MinBVersion| WORD) (|RVersion| WORD) (* \; "Bcpl fills in the actual microcode, Bcpl versions.") (|BVersion| WORD) (|MachineType| WORD) ( |MiscFXP| WORD) (* \; "FX for MISC context") (|Key| WORD) (* \; "= IFPValidKey if vmem consistent.") ( |SerialNumber| WORD) (* \; "Pup host number (Dorado/Dolphin)") (|EmulatorSpace| WORD) (* \; "Hiloc of bcpl space (always zero now)") (|ScreenWidth| WORD) (|NxtPMAddr| WORD) (* \; "Next page to be allocated in secondary page map table") (NIL WORD) (* \; "WAS NActivePages, Length of vmem in use") (NIL WORD) (* \; "WAS NDirtyPages, not used, but maintained as = NActivePages") (|filePnPMP0| WORD) (* \; "Sysout page number of first page of secondary page map table (\\PAGEMAP), which is where the secondary map pages themselves live" ) (|filePnPMT0| WORD) (* \; "Sysout page number of first page of primary page map table") (TELERAIDFXP WORD) (* \; "FX for TeleRaid server context") (NATIVE-START-MEM-PAGE WORD) (* \; "Unix page where native code starts") (NATIVE-LENGTH-PAGE WORD) (* \; "Unix page length of native code") (NATIVE-PAGE-OFFSET WORD) (* \; "Lisp Disk Page offset of native code") (|UserNameAddr| WORD) (* \; "Addresses in bcpl space (seg 0) of global user name and password") (|UserPswdAddr| WORD) (|StackBase| WORD) (* \; "Stack address where user stack starts") (FAULTHI WORD) (* \; "Microcode for page fault stores fault address here, then does context switch to FAULTFXP") (FAULTLO WORD) (DEVCONFIG WORD) (* \; "IT'S FOR KB,DISP TYPE") (* \; "Formerly REALPAGETABLE, back when it was always in Bcpl space.") (RPTSIZE WORD) (* \; "Number of entries in Real Page Table") (RPOFFSET WORD) (* \; "RP-RPOFFSET => index in table") ( MAXETHERBYTES WORD) (* \; "Number of bytes available in a pbi, not counting encapsulation (Dorado)") ( EMBUFVP WORD) (* \; "VP of a one-page emulator buffer") (|NSHost0| WORD) (* \; "Machine's 48-bit NS host number. Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in." ) (|NSHost1| WORD) (|NSHost2| WORD) (|MDSZone| WORD) (* \; "Obsolete -- was used by Dolphin 10MB network code.") (|MDSZoneLength| WORD) (EMUBUFFERS WORD) (* \; "Buffer space in segment 0 for swapping/disk activity") (EMUBUFLENGTH WORD) (* \; "Number of words of said space") (* |;;| "The following 2 are available if NEW_STOARGE is specified in C") (|ProcessSize| WORD) (* \; "Process size for which can be use as LISP space") (|StorageFullState| WORD) (* \; "Save last storage state") (ISFMAP WORD) (* |;;| "The following 4 are for \\MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!" ) (MISCSTACKFN FULLXPOINTER) (MISCSTACKARG1 FULLXPOINTER) (MISCSTACKARG2 FULLXPOINTER) ( MISCSTACKRESULT FULLXPOINTER) (|NRealPages| WORD) (* \; "Number pages of real memory") ( |LastLockedFilePage| WORD) (* \; "Last page of vmem that is locked--booting has to load at least that far.") (|LastDominoFilePage| WORD ) (* \; "Last sysout page reserved for Dandelion microcode") (|FPTOVPStart| WORD) (* \; "Sysout page where FPTOVP starts") (FAKEMOUSEBITS WORD) (* \; "Used to implement fake middle button on 2-button Dandelion.") (|DL24BitAddressable| WORD) (* \; "non-zero if DLion capable of addressing 32MB virtual memory") (REALPAGETABLEPTR FULLXPOINTER) (* \; "Address of real page table, set up by Bcpl (but not chained together)") (SYSDISK WORD) (* \; "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.") (|FullSpaceUsed| WORD) ( * \; "Non-zero if vmem beyond initial 8MB has been allocated.") (FAKEKBDAD4 WORD) (FAKEKBDAD5 WORD) (* |;;| "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with." ) (|XVmemFmapBase| WORD) (* \; "Bcpl stores isf map pointer to each partition here. First is redundant with ISFMAP field above.") ( NIL WORD) (NIL WORD) (|XVmemFmapHighBase| WORD) (* \; "Bcpl stores the highest vm page contained in this or earlier partition.") (NIL WORD) (NIL WORD) ( |XVmemDiskBase| FULLXPOINTER) (* \; "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).") (NIL FULLXPOINTER) (NIL FULLXPOINTER) (|DLLastVmemPage| FIXP) (* \; "DLion booting microcode puts length of vmem file here.") (|NActivePages| FIXP) (* \; "Length of vmem in use") (|NDirtyPages| FIXP) (* \; "not used, but maintained as = NActivePages")) ( CREATE (\\ALLOCBLOCK 43))) (BLOCKRECORD IOPAGE ((NIL 18 WORD) (DLMAINTPANEL WORD) (DLFLOPPYCMD WORD) (DLTTYPORTCMD WORD) ( DLPROCESSORCMD WORD) (NEWMOUSESTATE WORD) (DLBEEPCMD WORD) (DLRS232CMISCCOMMAND WORD) (DLRS232CPUTFLAG WORD) (DLRS232CGETFLAG WORD) (NIL 6 WORD) (DLFLOPPY WORD) (DLTTYOUT WORD) (NIL 1 WORD) (DLTTYIN WORD) (NIL 1 WORD) (DLPROCESSOR2 WORD) (DLPROCESSOR1 WORD) (DLPROCESSOR0 WORD) (NEWMOUSEX WORD) (NEWMOUSEY WORD) (DLBEEPFREQ WORD) (DLRS232CPARAMETERCSBLO WORD) (DLRS232CPARAMETERCSBHI WORD) ( DLRS232CSETRS366STATUS 3 WORD) (DLRS232CPUTCSBLO WORD) (DLRS232CPUTCSBHI WORD) (DLRS232CGETCSBLO WORD) (DLRS232CGETCSBHI WORD) (DLRS232CDEVICESTATUS WORD) (DLRS232CPARAMETEROUTCOME WORD) (DLTODVALID WORD) (DLTODLO WORD) (DLTODHI WORD) (DLTODLO2 WORD) (DLMOUSEX WORD) (DLMOUSEY WORD) (DLUTILIN WORD) ( DLKBDAD0 WORD) (DLKBDAD1 WORD) (DLKBDAD2 WORD) (DLKBDAD3 WORD) (DLKBDAD4 WORD) (DLKBDAD5 WORD) ( DLLSEPIMAGECSB 32 WORD) (DLIOPHARDWARECONFIG WORD) (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) ( DLRS232CPARAMETERCSBHI.11 WORD) (DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) ( DLETHERNET 12 WORD) (NIL 31 WORD) (DLDISPINTERRUPT WORD) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) ( DLCURSORX WORD) (DLCURSORY WORD) (DLCURSORBITMAP 16 WORD)) (ACCESSFNS IOPAGE ((DLCURSORBITMAPPTR ( \\ADDBASE DATUM 240)) (DLCURSORYPTR (\\ADDBASE DATUM 239)) (DLCURSORXPTR (\\ADDBASE DATUM 238)) ( DLDISPINTERRUPTPTR (\\ADDBASE DATUM 235)) (DLETHERNETPTR (\\ADDBASE DATUM 192)) (DLKBDAD5PTR ( \\ADDBASE DATUM 67)) (DLKBDAD4PTR (\\ADDBASE DATUM 66)) (DLKBDAD3PTR (\\ADDBASE DATUM 65)) ( DLKBDAD2PTR (\\ADDBASE DATUM 64)) (DLKBDAD1PTR (\\ADDBASE DATUM 63)) (DLKBDAD0PTR (\\ADDBASE DATUM 62) ) (DLUTILINPTR (\\ADDBASE DATUM 61)) (DLMOUSEYPTR (\\ADDBASE DATUM 60)) (DLMOUSEXPTR (\\ADDBASE DATUM 59)) (DLTODLOPTR (\\ADDBASE DATUM 56)) (DLMAINTPANELPTR (\\ADDBASE DATUM 18)))) (CREATE (\\ALLOCBLOCK 128))) (PUTPROPS EMADDRESS MACRO (ARGS ((LAMBDA (ADDR) (COND ((EQ |\\D1BCPLspace| |\\D0BCPLspace|) (LIST ( LIST (QUOTE OPCODES) (QUOTE GCONST) 0 0 (LRSH ADDR 8) (LOGAND ADDR 255)))) (T (BQUOTE (\\VAG2 (|fetch| |EmulatorSpace| |of| |\\InterfacePage|) \, ADDR))))) (EVAL (CAR ARGS))))) (PUTPROPS EMGETBASE MACRO ((OFFSET) (\\GETBASE (EMADDRESS OFFSET) 0))) (PUTPROPS EMPUTBASE MACRO ((OFFSET VAL) (\\PUTBASE (EMADDRESS OFFSET) 0 VAL))) (PUTPROPS EMULATORSEGMENT MACRO (NIL (|fetch| |EmulatorSpace| |of| |\\InterfacePage|))) (PUTPROPS EMPOINTER MACRO (X (COND ((NEQ |\\D1BCPLspace| |\\D0BCPLspace|) (LIST (QUOTE \\VAG2) (QUOTE (|fetch| (IFPAGE |EmulatorSpace|) |of| |\\InterfacePage|)) (CAR X))) ((ZEROP (CAR X)) NIL) (T (LIST ( QUOTE \\VAG2) |\\D0BCPLspace| (CAR X)))))) (PUTPROPS EMADDRESSP MACRO (X (LIST (QUOTE EQ) (LIST (QUOTE \\HILOC) (CAR X)) (COND ((EQ |\\D1BCPLspace| |\\D0BCPLspace|) |\\D0BCPLspace|) (T (QUOTE (|fetch| (IFPAGE |EmulatorSpace|) |of| |\\InterfacePage|))))))) (PUTPROP (QUOTE LLPARAMS) (QUOTE IMPORTDATE) (IDATE "12-Feb-2021 17:35:19")) (DATATYPE COMPILED-CLOSURE (FNHEADER ENVIRONMENT)) (RPAQQ \\COMPILED-CLOSURE 13) (CONSTANTS \\COMPILED-CLOSURE) (PUTPROPS \\EXTENDED.EQP MACRO (OPENLAMBDA (X Y) (COND ((EQ (NTYPX X) (NTYPX Y)) (SELECTC (NTYPX X) ( \\STACKP (EQ (|fetch| (STACKP EDFXP) |of| X) (|fetch| (STACKP EDFXP) |of| Y))) (\\COMPILED-CLOSURE ( EQDEFP X Y)) NIL))))) (PUTPROPS DPUTCODE MACRO ((FN CA SIZE) (SELECTQ (SYSTEMTYPE) (D (DEFC FN CA)) (/PUTPROP FN (QUOTE DCODE) CA)))) (PUTPROPS MCODEP MACRO ((X) (OR (ARRAYP X) (AND (LITATOM X) (ARRAYP (SELECTQ (SYSTEMTYPE) (D (GETD X)) (GETPROP X (QUOTE DCODE)))))))) (PUTPROPS CODELT MACRO ((CA N) (\\BYTELT CA N))) (PUTPROPS CODELT2 MACRO (OPENLAMBDA (DEF LC) (LOGOR (LLSH (CODELT DEF LC) BITSPERBYTE) (CODELT DEF ( ADD1 LC))))) (PUTPROPS CODESETA2 MACRO (OPENLAMBDA (DEF LC VALUE) (CODESETA DEF LC (LRSH VALUE BITSPERBYTE)) ( CODESETA DEF (ADD1 LC) (IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE)))))) (PUTPROPS CODESETA MACRO ((CA N NV) (\\BYTESETA CA N NV))) (PUTPROPS BYTESPERNAMEENTRY MACRO (NIL (UNFOLD (CONSTANT (WORDSPERNAMEENTRY)) BYTESPERWORD))) (PUTPROPS BYTESPERNTOFFSETENTRY MACRO (NIL (UNFOLD (WORDSPERNAMEENTRY) BYTESPERWORD))) (PUTPROPS GETNAMEENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (* |;;| "Must ALWAYS be called with DEF really being either a FNHEADER or a nametable pseudo-fnheader. Never use addbase to offset from it. This is because CODEBASEELT checks the BYTESWAPPED flag in the fnheader...." ) (FOR I FROM 0 TO (CONSTANT (SUB1 (BYTESPERNAMEENTRY))) DO (SETQ NUMBER (LOGOR (LLSH NUMBER BITSPERBYTE) (CODEBASELT DEF (IPLUS LC I))))) NUMBER))) (PUTPROPS GETNTFLAGS MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF LC))) (PUTPROPS GETNTOFFSET MACRO (OPENLAMBDA (DEF LC) (NTSLOT-OFFSET (GETNTOFFSETENTRY DEF LC)))) (PUTPROPS GETNTOFFSETENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (|for| I |from| 0 |to| ( CONSTANT (SUB1 (BYTESPERNTOFFSETENTRY))) |do| (SETQ NUMBER (LOGOR (LLSH NUMBER BITSPERBYTE) ( CODEBASELT DEF (IPLUS LC I))))) NUMBER))) (PUTPROPS GETNTTAG MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF (ADD1 LC)))) (PUTPROPS SETNAMEENTRY MACRO (OPENLAMBDA (DEF LC VALUE) (FOR I FROM (CONSTANT (SUB1 (BYTESPERNAMEENTRY ))) TO 0 BY -1 DO (CODEBASESETA DEF (IPLUS LC I) (LOGAND VALUE (CONSTANT (SUB1 (LLSH 1 BITSPERBYTE)))) ) (SETQ VALUE (LRSH VALUE BITSPERBYTE))))) (PUTPROPS WORDSPERNTOFFSETENTRY MACRO (NIL (WORDSPERNAMEENTRY))) (PUTPROPS NTSLOT-OFFSET MACRO ((X) (LOGAND 255 X))) (DEFMACRO NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM) (* |;;| "Use one form or another, depending on whether we're compiling for new 3-byte atoms or old 2-byte atom numbers." ) (COND ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*) (* \; "NEW ATOMS") (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, OLD-SYMBOL-FORM))))) (DEFOPTIMIZER BIG-VMEM-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* |;;| "Allow for differences between 4-byte pointers and 3-byte pointers..") (COND ((FMEMB :4-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, OLD-SYMBOL-FORM))))) (DEFOPTIMIZER SETSTKNAMEENTRY (CODEARRAY OFFSET VAL &ENVIRONMENT ENV) (* |;;| "Set the name entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LET ((BASE (|fetch| (ARRAYP BASE) |of| (\\\, CODEARRAY))) (VALUE (\\\, VAL))) (COND (( FIXP VALUE) (* \; "A 20-byte atom #. Make it an atom.") (\\PUTBASEPTR BASE (\\\, OFFSET) (\\VAG2 |\\AtomHI| VALUE))) (T (* \; "A 3-byte atom. Just use it.") (\\PUTBASEPTR BASE (\\\, OFFSET) VALUE))) ))) (T (BQUOTE (LET ((BASE (|fetch| (ARRAYP BASE) |of| (\\\, CODEARRAY)))) (\\PUTBASE BASE (\\\, OFFSET) (\\\, VAL))))))) (DEFOPTIMIZER SETSTKNTOFFSETENTRY (BASE OFFSET VAL &ENVIRONMENT ENV) (* |;;| "Set the offset entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\PUTBASEFIXP (\\\, BASE) (\\\, OFFSET) (\\\, VAL)))) (T (BQUOTE (\\PUTBASE (\\\, BASE ) (\\\, OFFSET) (\\\, VAL)))))) (DEFOPTIMIZER GETSTKNAMEENTRY (BASE OFFSET &ENVIRONMENT ENV) (* |;;| "Get a name entry out of a name table. BASE is the start of the name table; OFFSET is in words, not bytes or name entries." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\GETBASEPTR (\\\, BASE) ( \\\, OFFSET)))) (T (BQUOTE (\\GETBASE (\\\, BASE) (\\\, OFFSET)))))) (DEFOPTIMIZER GETSTKNTOFFSETENTRY (BASE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\GETBASEFIXP (\\\, BASE) (\\\, OFFSET)))) (T (BQUOTE (\\GETBASE (\\\, BASE) (\\\, OFFSET)))))) (DEFOPTIMIZER WORDSPERNAMEENTRY (&ENVIRONMENT ENV) (* |;;| "Number of words in a name-table \"Name\" entry--the space for the symbol. 1 for old symbol systems, 2 for 3-byte-atom systesm." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN 2))) ((AND CROSSCOMPILING (FMEMB :3-BYTE-INIT (COMPILER::ENV-TARGET-ARCHITECTURE ENV))) (BQUOTE (PROGN 2))) (T ( BQUOTE (PROGN 1))))) (DEFOPTIMIZER SETSTKNTOFFSET (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* |;;| "Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\\FIXCODENUM (\\\, BASE) (IDIFFERENCE (\\\, OFFSET) BYTESPERWORD) (\\\, TYPE)) (\\FIXCODENUM (\\\, BASE) (\\\, OFFSET) ( \\\, VAL))))) (T (BQUOTE (\\FIXCODENUM (\\\, BASE) (\\\, OFFSET) (IPLUS (\\\, TYPE) (\\\, VAL))))))) (DEFOPTIMIZER SETSTKNAME-RAW (BASE OFFSET VAL &ENVIRONMENT ENV) (* |;;| "Set the name entry for a name-table entry. This version works with raw storage, as opposed to SETSTKNAMEENTRY, which works on an ARRAYP." ) (* |;;| "If this optimizer changes, change SETSTKNAMEENTRY as well.") (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LET ((VALUE (\\\, VAL))) (COND ((FIXP VALUE) (* \; "A 20-byte atom #. Make it an atom.") (\\PUTBASEPTR (\\\, BASE) (\\\, OFFSET) (\\VAG2 |\\AtomHI| VALUE))) (T (* \; "A 3-byte atom. Just use it.") (\\PUTBASEPTR (\\\, BASE) (\\\, OFFSET) VALUE)))))) (T (BQUOTE (\\PUTBASE (\\\, BASE) (\\\, OFFSET) (\\\, VAL)))))) (DEFOPTIMIZER SETSTKNTOFFSET-RAW (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* |;;| "Set the offset entry for a name-table entry. This version works on raw storage, vs SETSTKNAMEOFFSETENTRY, which is supposed to work on codearrays. Any changes here should be made there, as well. TYPE must already be shifted left by 14 bits." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\\PUTBASE (\\\, BASE) (\\\, OFFSET) (\\\, TYPE)) (\\PUTBASE (\\\, BASE) (IPLUS (\\\, OFFSET) 1) (\\\, VAL))))) (T (BQUOTE ( \\PUTBASE (\\\, BASE) (\\\, OFFSET) (IPLUS (\\\, TYPE) (\\\, VAL))))))) (DEFOPTIMIZER NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* |;;| "Allow for differences between 3-byte atoms and 2-byte atoms.") (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, OLD-SYMBOL-FORM))))) (DEFOPTIMIZER MAKE-NTENTRY (TYPE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (IPLUS (CONSTANT (LLSH (\\\, TYPE) 16)) (\\\, OFFSET)) )) (T (BQUOTE (IPLUS (CONSTANT (\\\, TYPE)) (\\\, OFFSET)))))) (DEFOPTIMIZER NULL-NTENTRY (VALUE &ENVIRONMENT ENV) (* |;;| "Predicate: Is VALUE a null entry in a name table? I.e., does it result from fetching the entry at the end that`s all zeros? For 2-byte atoms, that's the same as being zero. For 3-byte atoms, it's the same as being NIL." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (NULL (\\\, VALUE)))) (T ( BQUOTE (EQ (\\\, VALUE) 0))))) (DEFOPTIMIZER NTSLOT-VARTYPE (X &ENVIRONMENT ENV) (* |;;| "Given the contents of a name-table Offset entry, return the variable-type bits at the top of the entry. THE RESULT IS RETURNED SHEFTED LEFT 14 BITS, THE USUAL REPRESENTATION." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LOGAND 49153 (LRSH (\\\, X) 16)))) (T (BQUOTE (LOGAND (\\\, X) 49152))))) (ACCESSFNS CODEARRAY ((STKMIN (CODELT2 DATUM 0) (CODESETA2 DATUM 0 NEWVALUE)) (NA (SIGNED (CODELT2 DATUM 2) BITSPERWORD) (CODESETA2 DATUM 2 (UNSIGNED NEWVALUE BITSPERWORD))) (PV (SIGNED (CODELT2 DATUM 4) BITSPERWORD) (CODESETA2 DATUM 4 (UNSIGNED NEWVALUE BITSPERWORD))) (STARTPC (CODELT2 DATUM 6) ( CODESETA2 DATUM 6 NEWVALUE)) (ARGTYPE (LOGAND (LRSH (CODELT DATUM 8) 4) 3) (CODESETA DATUM 8 (LOGOR ( LOGAND (CODELT DATUM 8) 207) (LLSH (LOGAND NEWVALUE 3) 4)))) (FRAMENAME (\\VAG2 (LOGAND (CODELT2 DATUM 8) 4095) (CODELT2 DATUM 10)) (\\FIXCODEPTR DATUM 11 (EVQ NEWVALUE))) (NTSIZE (CODELT2 DATUM 12) ( CODESETA2 DATUM 12 NEWVALUE)) (NLOCALS (CODELT DATUM 14) (CODESETA DATUM 14 NEWVALUE)) (FVAROFFSET ( CODELT DATUM 15) (CODESETA DATUM 15 NEWVALUE))) (ACCESSFNS CODEARRAY ((LSTARP (ILESSP (|fetch| ( CODEARRAY NA) |of| DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (ALIGNED (IPLUS (|fetch| (CODEARRAY NTSIZE) |of| DATUM) (|fetch| (CODEARRAY OVERHEADWORDS) |of| T))) (FIXED NIL (|replace| (CODEARRAY STKMIN) |of| DATUM |with| (\\STKMIN DATUM))) (FRAMENAME# (PROGN 8))))) (RECORD OPCODE (OP# OPCODENAME OPNARGS OPPRINT LEVADJ UFNFN UNIMPL)) (GLOBALVARS \\OPCODES) (RPAQQ PVARCODE 32768) (RPAQQ FVARCODE 49152) (RPAQQ IVARCODE 0) (RPAQQ VARCODEMASK 49152) (CONSTANTS PVARCODE FVARCODE IVARCODE VARCODEMASK) (RPAQQ \\NT.IVARCODE 0) (RPAQQ \\NT.PVARCODE 2) (RPAQQ \\NT.FVARCODE 3) (CONSTANTS \\NT.IVARCODE \\NT.PVARCODE \\NT.FVARCODE) (PUTPROP (QUOTE LLCODE) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 10:45:33")) (RPAQQ \\ERRORMESSAGELIST ("SYSTEM ERROR" " " "STACK OVERFLOW" "ILLEGAL RETURN" "ARG NOT LIST" "HARD DISK ERROR" "ATTEMPT TO SET NIL OR T" "ATTEMPT TO RPLAC NIL" "UNDEFINED OR ILLEGAL GO" "FILE WON'T OPEN" "NON-NUMERIC ARG" "ATOM TOO LONG" "ATOM HASH TABLE FULL" "FILE NOT OPEN" "ARG NOT LITATOM" "! too many files open" "END OF FILE" "ERROR" "BREAK" "ILLEGAL STACK ARG" "FAULT IN EVAL" "ARRAYS FULL" "FILE SYSTEM RESOURCES EXCEEDED" "FILE NOT FOUND" "BAD SYSOUT FILE" "UNUSUAL CDR ARG LIST" "HASH TABLE FULL" "ILLEGAL ARG" "ARG NOT ARRAY" "ILLEGAL OR IMPOSSIBLE BLOCK" "STACK PTR HAS BEEN RELEASED" "STORAGE FULL" "ATTEMPT TO USE ITEM OF INCORRECT TYPE" "ILLEGAL DATA TYPE NUMBER" "DATA TYPES FULL" "ATTEMPT TO BIND NIL OR T" "! too many user interrupt characters" "! read-macro context error" "ILLEGAL READTABLE" "ILLEGAL TERMINAL TABLE" "! swapblock too big for buffer" "PROTECTION VIOLATION" "BAD FILE NAME" "USER BREAK" "UNBOUND ATOM" "UNDEFINED CAR OF FORM" "UNDEFINED FUNCTION" "CONTROL-E" "FLOATING UNDERFLOW" "FLOATING OVERFLOW" "OVERFLOW" "ARG NOT HARRAY" "TOO MANY ARGUMENTS")) (DEFOPTIMIZER LISPERROR (MESSAGE ARG) (BQUOTE (\\LISPERROR (\\\, ARG) (\\\, (CL:IF (CL:STRINGP MESSAGE ) (FOR X IN \\ERRORMESSAGELIST AS I FROM 0 WHEN (CL:EQUAL X MESSAGE) DO (RETURN I) FINALLY (RETURN ( HELP "Unknown error message" (LIST MESSAGE ARG)))) MESSAGE))))) (PUTPROP (QUOTE AERROR) (QUOTE IMPORTDATE) (IDATE "16-May-1990 11:58:35")) (RECORD BASEBYTESTREAM STREAM (SUBRECORD STREAM) (ACCESSFNS ((BIASOFFST (|fetch| (STREAM FW6) |of| DATUM) (|replace| (STREAM FW6) |of| DATUM |with| NEWVALUE)) (BBSNCHARS (|fetch| (STREAM FW7) |of| DATUM) (|replace| (STREAM FW7) |of| DATUM |with| NEWVALUE)) (WRITEXTENSIONFN (|fetch| (STREAM F1) |of| DATUM) (|replace| (STREAM F1) |of| DATUM |with| NEWVALUE))))) (PUTPROPS \\INSTREAMARG MACRO ((STRM NOERRORFLG) (\\GETSTREAM STRM (QUOTE INPUT) NOERRORFLG))) (PUTPROPS \\OUTSTREAMARG MACRO ((STRM NOERRORFLG) (\\GETSTREAM STRM (QUOTE OUTPUT) NOERRORFLG))) (PUTPROPS \\STREAMARG MACRO (OPENLAMBDA (STRM NOERRORFLG) (COND (NOERRORFLG (\\GETSTREAM STRM NIL T)) (T (\\DTEST STRM (QUOTE STREAM)))))) (PUTPROP (QUOTE AOFD) (QUOTE IMPORTDATE) (IDATE "13-Sep-1990 16:39:58")) (PUTPROPS .SPACECHECK. MACRO ((STRM N) (AND \\THISFILELINELENGTH (IGREATERP (IPLUS N (|fetch| CHARPOSITION |of| STRM)) \\THISFILELINELENGTH) (FRESHLINE STRM)))) (PUTPROPS \\CHECKRADIX MACRO (LAMBDA (R) (COND ((OR (NOT (SMALLP R)) (ILESSP R 1) (IGREATERP R 36)) ( \\INVALID.RADIX R)) (T R)))) (PUTPROPS \\XCCSFILEOUTCHARFN MACRO ((OUTSTREAM CHARCODE) (* |;;;| "Encoder for XCCS format. Default decoder.") (COND ((EQ CHARCODE (CHARCODE EOL)) (COND ((NOT ( \\RUNCODED OUTSTREAM)) (* \; "Charset is a constant 0") (\\BOUT OUTSTREAM (\\CHARSET (CHARCODE EOL)))) ((EQ (\\CHARSET (CHARCODE EOL)) (|ffetch| (STREAM CHARSET) |of| OUTSTREAM))) (T (\\BOUT OUTSTREAM NSCHARSETSHIFT) (\\BOUT OUTSTREAM (|freplace| (STREAM CHARSET) |of| OUTSTREAM |with| (\\CHARSET ( CHARCODE EOL)))))) (\\BOUT OUTSTREAM (SELECTC (|ffetch| EOLCONVENTION |of| OUTSTREAM) (CR.EOLC ( CHARCODE CR)) (LF.EOLC (CHARCODE LF)) (CRLF.EOLC (\\BOUT OUTSTREAM (CHARCODE CR)) (* |;;| "Don't put out high-order byte preceding LF. The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes" ) (CHARCODE LF)) (SHOULDNT))) (|freplace| CHARPOSITION |of| OUTSTREAM |with| 0)) (T (COND ((NOT ( \\RUNCODED OUTSTREAM)) (\\BOUT OUTSTREAM (\\CHARSET CHARCODE)) (\\BOUT OUTSTREAM (\\CHAR8CODE CHARCODE ))) ((EQ (\\CHARSET CHARCODE) (|ffetch| (STREAM CHARSET) |of| OUTSTREAM)) (\\BOUT OUTSTREAM ( \\CHAR8CODE CHARCODE))) (T (\\BOUT OUTSTREAM NSCHARSETSHIFT) (\\BOUT OUTSTREAM (|freplace| (STREAM CHARSET) |of| OUTSTREAM |with| (\\CHARSET CHARCODE))) (\\BOUT OUTSTREAM (\\CHAR8CODE CHARCODE)))) ( |freplace| CHARPOSITION |of| OUTSTREAM |with| (PROGN (* \; "Ugh. Don't overflow") (IPLUS16 (|ffetch| CHARPOSITION |of| OUTSTREAM) 1))))))) (PUTPROP (QUOTE APRINT) (QUOTE IMPORTDATE) (IDATE "17-Jan-2020 05:51:20")) (GLOBALVARS \\BCPLDISPLAY) (ACCESSFNS LINEBUFFER ((LPARCOUNT (|fetch| FW6 |of| DATUM) (|replace| FW6 |of| DATUM |with| NEWVALUE)) (LBRKCOUNT (|fetch| FW7 |of| DATUM) (|replace| FW7 |of| DATUM |with| NEWVALUE)) (LINEBUFSTATE ( |fetch| F5 |of| DATUM) (|replace| F5 |of| DATUM |with| NEWVALUE)) (* \; "F4 is free. EJS, 7/8/85") ( KEYBOARDSTREAM (|fetch| F2 |of| DATUM) (|replace| F2 |of| DATUM |with| NEWVALUE)) (PEEKEDCHAR (|fetch| F3 |of| DATUM) (|replace| F3 |of| DATUM |with| NEWVALUE)) (* \; "Character read by PEEKC") (LBFLAGS ( |fetch| FW9 |of| DATUM) (|replace| FW9 |of| DATUM |with| NEWVALUE)) (* |;;| "True if peeked char was echoed when peeked. Could use this to determine whether to echo later or not, but that would be incompatible with Interlisp-10, so this field not used" )) (ACCESSFNS LINEBUFFER ((LBFLAGBASE (LOCF (|fetch| LBFLAGS |of| DATUM)))) (BLOCKRECORD LBFLAGBASE (( PEEKEDECHOFLG FLAG) (INSTRINGP FLAG))))) (RPAQQ LINEBUFFERSTATES (FILLING.LBS READING.LBS RETYPING.LBS)) (RPAQQ FILLING.LBS 0) (RPAQQ READING.LBS 1) (RPAQQ RETYPING.LBS 2) (CONSTANTS FILLING.LBS READING.LBS RETYPING.LBS) (PUTPROPS \\INTERMP MACRO ((OFD) (EQ OFD \\LINEBUF.OFD))) (PUTPROPS \\OUTTERMP MACRO ((OFD) (EQ OFD \\TERM.OFD))) (GLOBALVARS \\DEFAULTLINEBUF) (PUTPROP (QUOTE ATERM) (QUOTE IMPORTDATE) (IDATE "16-May-1990 12:08:04")) (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))) (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 \\ADDBASE2 MACRO (OPENLAMBDA (BASE N) (\\ADDBASE (\\ADDBASE BASE N) N))) (PUTPROPS \\ADDBASE4 MACRO (OPENLAMBDA (BASE N) (\\ADDBASE2 (\\ADDBASE2 BASE N) N))) (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 \\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)))) (RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (UNBOXEDBLOCK.GCT 0))) (RPAQQ CODEBLOCK.GCT 2) (RPAQQ PTRBLOCK.GCT 1) (RPAQQ UNBOXEDBLOCK.GCT 0) (CONSTANTS (CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (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 |\\ArrayBlockHeaderCells| 1) (RPAQQ |\\ArrayBlockHeaderWords| 2) (RPAQQ |\\ArrayBlockTrailerCells| 1) (RPAQQ |\\ArrayBlockTrailerWords| 2) (RPAQ |\\ArrayBlockOverheadCells| (IPLUS |\\ArrayBlockHeaderCells| |\\ArrayBlockTrailerCells|)) (RPAQ |\\ArrayBlockOverheadWords| (IPLUS |\\ArrayBlockHeaderWords| |\\ArrayBlockTrailerWords|)) (RPAQQ |\\ArrayBlockLinkingCells| 2) (RPAQ |\\MinArrayBlockSize| (IPLUS |\\ArrayBlockOverheadCells| |\\ArrayBlockLinkingCells|)) (RPAQQ |\\MaxArrayBlockSize| 65535) (RPAQ |\\MaxArrayNCells| (IDIFFERENCE |\\MaxArrayBlockSize| |\\ArrayBlockOverheadCells|)) (RPAQQ |\\MaxArrayLen| 65535) (RPAQQ \\ABPASSWORDSHIFT 3) (RPAQ |\\ArrayBlockPassword| (LRSH 43690 \\ABPASSWORDSHIFT)) (RPAQ |\\FreeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH UNBOXEDBLOCK.GCT 1))) (RPAQ |\\UsedArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) 1)) (RPAQ |\\CodeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT 1) 1)) (CONSTANTS |\\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 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))) (RPAQQ \\ST.BYTE 0) (RPAQQ \\ST.POS16 1) (RPAQQ \\ST.INT32 2) (RPAQQ \\ST.CODE 4) (RPAQQ \\ST.PTR 6) (RPAQQ \\ST.FLOAT 7) (RPAQQ \\ST.BIT 8) (RPAQQ \\ST.PTR2 11) (CONSTANTS (\\ST.BYTE 0) (\\ST.POS16 1) (\\ST.INT32 2) (\\ST.CODE 4) (\\ST.PTR 6) (\\ST.FLOAT 7) ( \\ST.BIT 8) (\\ST.PTR2 11)) (RPAQQ \\MAX.CELLSPERHUNK 64) (CONSTANTS \\MAX.CELLSPERHUNK) (RPAQQ \\IN.MAKEINIT NIL) (CONSTANTS (\\IN.MAKEINIT)) (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))) (DATATYPE ARRAYP ((* |;;| "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.")) (* |;;| "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) (* \; "Used for header and trailer"))) (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|)))) (GLOBALVARS |\\NxtArrayPage| \\FREEBLOCKBUCKETS \\HUNKING?) (PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (|fetch| DTDSIZE |of| (\\GETDTD NTYPX)) WORDSPERCELL))) (PUTPROP (QUOTE LLARRAYELT) (QUOTE IMPORTDATE) (IDATE "15-Sep-1994 11:08:59")) (DEFOPTIMIZER PUTBASEPTRX (&REST ARGS) (CONS (QUOTE (OPENLAMBDA (DATUM OFFSET NEWVALUE) ( UNINTERRUPTABLY (\\PUTBASE DATUM OFFSET (LOGOR (LOGAND 61440 (\\GETBASE DATUM OFFSET)) (LOGAND ( \\HILOC NEWVALUE) 4095))) (\\PUTBASE DATUM (ADD1 OFFSET) (\\LOLOC NEWVALUE)) NEWVALUE))) ARGS)) (RPAQQ \\SMALLP 1) (RPAQQ \\FIXP 2) (RPAQQ \\FLOATP 3) (RPAQQ \\LITATOM 4) (RPAQQ \\LISTP 5) (RPAQQ \\ARRAYP 6) (RPAQQ \\STACKP 8) (RPAQQ \\VMEMPAGEP 10) (RPAQQ \\STREAM 11) (RPAQQ \\NEW-ATOM 21) (CONSTANTS \\SMALLP \\FIXP \\FLOATP \\LITATOM \\LISTP \\ARRAYP \\STACKP \\VMEMPAGEP \\STREAM \\NEW-ATOM) (RPAQQ \\BUILT-IN-SYSTEM-TYPES ((SMALLP) (FIXP 2) (FLOATP 2) (LITATOM) (LISTP 4 (0 2)) (ARRAYP 6 (0)) (STRINGP 6 (0)) (STACKP 2 NIL \\RECLAIMSTACKP) (CHARACTER) (VMEMPAGEP 256 NIL RELEASINGVMEMPAGE) ( STREAM) (BITMAP) (COMPILED-CLOSURE 4 (0 2)) (ONED-ARRAY 8 (0)) (TWOD-ARRAY 10 (0)) (GENERAL-ARRAY 10 ( 0 8)) (BIGNUM) (RATIO) (COMPLEX) (PATHNAME) (NEW-ATOM 10 (2 4 6)) (FILLER22) (FILLER23) (FILLER24) ( FILLER25) (FILLER26) (FILLER27) (FILLER28) (FILLER29) (FILLER30))) (BLOCKRECORD DTD ((NIL BITS 2) (DTDOBSOLETE FLAG) (* \; "True for type of a redeclared datatype--not allowed to allocate more of these") (DTDFINALIZABLE FLAG) (* \; "True if finalization exists for this type") (DTDNAME POINTER) (* \; "Type name -- a symbol ") (DTDCNT0 WORD) (* \; "Incremental box count -- this plus DTDOLDCNT is the true box count") (DTDSIZE WORD) (* \; "Length of datum in words") (DTDFREE FULLXPOINTER) (* \; "Pointer to first object on free chain, or NIL. Not used for LISTP") (DTDLOCKEDP FLAG) (* \; "True if objects of this type must be locked down (not pagefault)") (DTDHUNKP FLAG) (* \; "True if this type is used as an array hunk type") (DTDGCTYPE BITS 2) (* \; "For hunk datatypes, is analogous to arrayblock's GCTYPE") (DTDDESCRS POINTER) (DTDTYPESPECS POINTER) (DTDPTRS POINTER) (* \; "List of word offsets inside datum where reference-counted pointers are stored -- used by GC") ( DTDOLDCNT FIXP) (* \; "'Box count' -- number of objects of this type ever allocated") (DTDNEXTPAGE FIXP) (* \; "Currently only for LISTP pages -- page number of next page on chain of non-full cons pages") ( DTDTYPEENTRY WORD) (* |;;| "The word stored in the type table for objects of this type. Hi bits have numberp tags, ref countable, etc." ) (DTDSUPERTYPE WORD) (* \; "Type number of immediate supertype, or zero if none")) (ACCESSFNS DTD (( DTDCNTLOC (\\ADDBASE DATUM 4)) (DTDCNT (IPLUS (|fetch| DTDOLDCNT DATUM) (|fetch| DTDCNT0 DATUM)) ( UNINTERRUPTABLY (|replace| DTDOLDCNT |of| DATUM |with| NEWVALUE) (|replace| DTDCNT0 |of| DATUM |with| 0)))))) (PUTPROPS \\GETDTD MACRO ((|typeNum|) (ADDBASE |\\DTDSpaceBase| (ITIMES |typeNum| 18)))) (DEFOPTIMIZER \\TYPEMASK.UFN (&REST X) (LET ((CE (CONSTANTEXPRESSIONP (CADR X)))) (|if| CE |then| ( BQUOTE ((OPCODES TYPEMASK.N (\\\, (CAR CE))) (\\\, (CAR X)))) |else| (QUOTE IGNOREMACRO)))) (RPAQQ \\GUARDSTORAGEFULL 128) (RPAQQ \\GUARD1STORAGEFULL 64) (CONSTANTS \\GUARDSTORAGEFULL \\GUARD1STORAGEFULL) (GLOBALVARS |\\NxtMDSPage| |\\LeastMDSPage| |\\SecondArrayPage| |\\SecondMDSPage| \\MDSFREELISTPAGE |\\MaxSysTypeNum| |\\MaxTypeNumber| \\STORAGEFULL \\INTERRUPTSTATE \\PENDINGINTERRUPT) (PUTPROP (QUOTE LLDATATYPE) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:57:50")) (ACCESSFNS POINTER ((PAGE# (IPLUS (LLSH (\\HILOC DATUM) 8) (LRSH (\\LOLOC DATUM) 8))) (WORDINPAGE ( LOGAND (\\LOLOC DATUM) 255)) (CELLINPAGE (LRSH (|fetch| WORDINPAGE |of| DATUM) 1)) (BYTEINPAGE (LLSH ( |fetch| WORDINPAGE |of| DATUM) 1)) (SEGMENT# (\\HILOC DATUM)) (WORDINSEGMENT (\\LOLOC DATUM)) ( CELLINSEGMENT (LRSH (|fetch| WORDINSEGMENT |of| DATUM) 1)) (WORD# (|fetch| WORDINPAGE |of| DATUM)) ( DBLWORD# (|fetch| CELLINPAGE |of| DATUM)) (PAGEBASE (\\VAG2 (\\HILOC DATUM) (LOGAND (\\LOLOC DATUM) 65280)))) (CREATE (\\VAG2 (LRSH PAGE# 8) (LLSH (LOGAND PAGE# 255) 8)))) (ACCESSFNS WORD ((HIBYTE (LRSH DATUM 8)) (LOBYTE (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH HIBYTE 8) LOBYTE))) (PUTPROPS PTRGTP MACRO (OPENLAMBDA (X Y) (OR (IGREATERP (\\HILOC X) (\\HILOC Y)) (AND (EQ (\\HILOC X) (\\HILOC Y)) (IGREATERP (\\LOLOC X) (\\LOLOC Y)))))) (PUTPROPS .COERCE.TO.SMALLPOSP. DMACRO (OPENLAMBDA (X) (COND ((SMALLPOSP X) X) (T (\\ILLEGAL.ARG X)))) ) (PUTPROPS .COERCE.TO.BYTE. DMACRO (OPENLAMBDA (X) (COND ((AND (SMALLPOSP X) (ILESSP X (CONSTANT (LLSH 1 BITSPERBYTE)))) X) (T (\\ILLEGAL.ARG X))))) (BLOCKRECORD LISTP ((* |;;| "Describes a CONS cell.") (CAR POINTER) (CDR POINTER)) (CREATE (CREATECELL \\LISTP)) (* |;;| "FOLLOWING ARE CDR-CODE FIELDS") (BLOCKRECORD LISTP ((CDRCODE BITS 4) (CARFIELD XPOINTER))) (* |;;| "For chaining together free cells on a page:") (BLOCKRECORD LISTP ((NEXTFREE BYTE) (NIL BITS 24))) (ACCESSFNS LISTP ((FULLCARFIELD NIL (\\PUTBASEPTR DATUM 0 NEWVALUE)))) (* |;;| "because replace of XPOINTER is slow, the CAR field is stored with PUTBASEPTR, even though that smashes the hi byte" )) (BLOCKRECORD CONSPAGE ((* |;;| "Describes a page of CONS cells, which (when free) are chained together thru the top byte.") (NIL 2 FIXP) (* \; "Empty cells, space for another 2 CONS cells if we can figure out how.") (CNT BYTE) (* \; "# of cells free on this page") (NEXTCELL BYTE) (* \; "WORD offset of next free cell (not guaranteed to be 0 if no free cells)") (NIL WORD) (* \; "Padding") (NEXTPAGE FIXP) (* \; "Next CONS page on the DTD's free list, for searching for cells."))) (RPAQQ CONSCONSTANTS (\\CDR.ONPAGE \\CDR.NIL \\CDR.INDIRECT \\CDR.MAXINDIRECT \\CONSPAGE.LAST)) (RPAQQ \\CDR.ONPAGE 8) (RPAQQ \\CDR.NIL 8) (RPAQQ \\CDR.INDIRECT 0) (RPAQQ \\CDR.MAXINDIRECT 7) (RPAQQ \\CONSPAGE.LAST 65535) (CONSTANTS \\CDR.ONPAGE \\CDR.NIL \\CDR.INDIRECT \\CDR.MAXINDIRECT \\CONSPAGE.LAST) (PUTPROPS LOCAL MACRO ((X) X)) (PUTPROPS ALLOCAL MACRO ((X) X)) (PUTPROP (QUOTE LLNEW) (QUOTE IMPORTDATE) (IDATE " 2-Feb-1995 16:21:44")) (PUTPROPS CHECK MACRO (ARGS (COND ((AND (BOUNDP (QUOTE CHECK)) CHECK) (CONS (QUOTE PROGN) (|for| I |in| ARGS |collect| (LIST (QUOTE OR) I (LIST (QUOTE RAID) (KWOTE (LIST (QUOTE |Check-failure:|) I))))) )) (T (CONS COMMENTFLG ARGS))))) (PUTPROPS |\\StatsZero| BYTEMACRO (OPENLAMBDA (N) (\\PUTBASE N 0 0) (\\PUTBASE N 1 0))) (PUTPROPS |\\StatsAdd1| DMACRO (OPENLAMBDA (A) (PROG ((LO (IPLUS16 (\\GETBASE A 1) 1))) (DECLARE ( LOCALVARS LO)) (* \; "Increment double word at A by 1") (\\PUTBASE A 1 LO) (COND ((EQ LO 0) (\\PUTBASE A 0 (ADD1 (\\GETBASE A 0)))))))) (PUTPROPS IPLUS16 MACRO ((X Y) (* \; "Kludge to do 16-bit plus") (\\LOLOC (\\ADDBASE X Y)))) (PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0)))) (PROGN (PUTPROPS SETXVAR MACRO (X (BQUOTE (SETQ.NOREF \, (CADAR X) \, (CADR X))))) (PUTPROPS SETXVAR DMACRO (X (OR (AND (EQ (CAAR X) (QUOTE QUOTE)) (LITATOM (CADAR X))) (SHOULDNT)) (GLOBALVARS \\VALSPACE ) (LIST (QUOTE SETQ.NOREF) (CADAR X) (CADR X))))) (PUTPROPS SETQ.NOREF DMACRO ((VAR VAL) (\\PUTBASEPTR (LOCF (|fetch| (LITATOM VALUE) |of| (QUOTE VAR))) 0 VAL))) (PROGN (PUTPROPS IEQ MACRO ((X Y) (IEQP X Y))) (PUTPROPS IEQ DMACRO (= . EQ))) (RPAQQ |WordsPerPage| 256) (CONSTANTS |WordsPerPage|) (ACCESSFNS LITATOM ((DEFINITIONCELL (\\DEFCELL DATUM)) (PROPCELL (\\PROPCELL DATUM)) (VCELL (\\VALCELL DATUM)) (PNAMECELL (\\PNAMECELL DATUM))) (* |;;| "VCELL can also be accessed directly from a value index via the record VALINDEX (as in \\SETGLOBALVAL.UFN) --- Similarly, PNAMEINDEX accesses PNAMECELL for use by \\MKATOM and UNCOPYATOM" ) (TYPE? (LITATOM DATUM)) (BLOCKRECORD PROPCELL ((NIL BITS 4) (* \; "former flags locations") ( PROPLIST POINTER) (NIL BITS 8) (* \; "Package byte") (NIL BITS 8) (* \; "Flags from defcell") (* |;;| "PROPCell flags:") (NIL BITS 1) (GENSYMP FLAG) (FATPNAMEP FLAG) (NIL BITS 5) (* |;;| "Filler for final cell:") (NIL BITS 8)))) (SYNONYM CL:SYMBOL (LITATOM)) (ACCESSFNS VALINDEX ((VCELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* \; "Xerox Lisp traditional symbol") (\\ADDBASE2 \\PNPSPACE (IPLUS \\NEWATOM-VALOFFSET (ITIMES 10 DATUM))) ) (T (* \; "New symbol") (* \; "'90/07/19 ON") (\\ADDBASE DATUM \\NEWATOM-VALOFFSET)))))) (BLOCKRECORD VCELL ((VALUE FULLPOINTER))) (BLOCKRECORD DEFINITIONCELL ((CCODEP FLAG) (FASTP FLAG) (ARGTYPE BITS 2) (* \; "Former flag location") (DEFPOINTER POINTER) (NIL POINTER) (* \; "Proplist cell") (NIL BITS 8) (* \; "package") (* |;;| "DEFCELL flags overflow from top 4 bits of the real cell:") (NIL BITS 4) (PSEUDOCODEP FLAG) (NIL BITS 3) (* |;;| "proplist falgs and filler:") (NIL BITS 16)) (BLOCKRECORD DEFINITIONCELL ((DEFCELLFLAGS BITS 4) (NIL POINTER) (* \; "defn ptr") (NIL BITS 4) (NIL POINTER) (* \; "filler for proplist ptr") ( NIL BITS 8) (AUXDEFCELLFLAGS BYTE) (NIL BITS 16)))) (BLOCKRECORD FNHEADER ((STKMIN WORD) (NA SIGNEDWORD) (PV SIGNEDWORD) (STARTPC WORD) (CLOSUREP FLAG) (* \; "T if this is a \"compiled closure\"") (BYTESWAPPED FLAG) (* \; "T if, on 386, we reswapped the code section of this function for faster access.") (ARGTYPE BITS 2) (* \; "0 = LAMBDA") (* \; "2 = LAMBDA nospread") (* \; "1 = NLAMBDA") (* \; "3 = NLAMBDA nospread") (* |;;| "4 NIL BITS USED TO BE HERE.") (\#FRAMENAME XPOINTER) (NTSIZE WORD) (* \; "Size of the Name Table, IN WORDS. This value is always rounded up to the next Quad-word in size, and there' guaranteed to be one entry of zeros in the length." ) (NLOCALS BYTE) (FVAROFFSET BYTE)) (ACCESSFNS FNHEADER ((LSTARP (ILESSP (|fetch| (FNHEADER NA) |of| DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (NATIVE (PROGN NIL)) (* \; "T if this is a NATIVE-code function (never true!)") (ALIGNED (IPLUS (|fetch| (FNHEADER NTSIZE) |of| DATUM) (|fetch| (FNHEADER OVERHEADWORDS) |of| T))) (FIXED NIL (|replace| (FNHEADER STKMIN) |of| DATUM |with| (\\STKMIN DATUM T))) (NPVARWORDS (UNFOLD (ADD1 (|fetch| (FNHEADER PV) |of| DATUM)) WORDSPERQUAD )) (FRAMENAME (|fetch| (FNHEADER \#FRAMENAME) |of| DATUM) (UNINTERRUPTABLY (CHECK (NEQ (\\HILOC DATUM) \\STACKHI)) (\\DELREF (|fetch| (FNHEADER \#FRAMENAME) |of| DATUM)) (\\ADDREF NEWVALUE) (|replace| ( FNHEADER \#FRAMENAME) |of| DATUM |with| NEWVALUE)))))) (BLOCKRECORD PNAMECELL ((NIL BITS 4) (PNAMEBASE XPOINTER) (NIL POINTER) (* \; "val, def, prop cells") (NIL POINTER) (NIL POINTER) (PACKAGEINDEX BYTE) (NIL BITS 24) (* \; "filler for other flags")) ( BLOCKRECORD PNAMECELL ((FULLPNAMEBASE FULLXPOINTER) (* \; "Replacing this smashes PACKAGEINDEX to 0")) ) (ACCESSFNS PNAMECELL ((PACKAGE (LET ((I (FETCH (PNAMECELL PACKAGEINDEX) OF DATUM))) (* \; "This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound." ) (COND ((EQ 0 I) NIL) (T (CL:AREF *PACKAGE-FROM-INDEX* I)))) (REPLACE (PNAMECELL PACKAGEINDEX) OF DATUM WITH (IF (NULL NEWVALUE) THEN *UNINTERNED-PACKAGE-INDEX* ELSE (CL::%PACKAGE-INDEX NEWVALUE)))))) ) (ACCESSFNS PACKAGEINDEX ((PACKAGE (IF (EQ 0 DATUM) (* \; "This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound." ) THEN NIL ELSE (CL:AREF *PACKAGE-FROM-INDEX* DATUM))))) (BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE) (* \; "Length is always here, be the pname thin or fat") ( PNAMEFATPADDINGBYTE BYTE) (* \; "This byte is zero for fat pnames so that the pname chars are word-aligned"))) (ACCESSFNS PNAMEINDEX ((PNAMECELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* \; "Xerox Lisp traditional symbol") (\\ADDBASE \\OLDATOMSPACE (IPLUS \\NEWATOM-PNAMEOFFSET (ITIMES 10 DATUM)))) (T (* \; "New symbol") (* \; "'90/07/19 ON") (\\ADDBASE DATUM \\NEWATOM-PNAMEOFFSET)))))) (BLOCKRECORD NEW-ATOM ((* |;;| "An extended symbol, for expanding atom space. Kept in its own datatype.") (PNAME XPOINTER) (* \; "PNAME, same as litatom.") (VALUE POINTER) (DEF POINTER) (PROPLIST POINTER) (* |;;| "Flags that used to be above the pointers, e.g. package, ccodep, gensymp:") (NIL BITS 32))) (PUTPROPS \\DEFCELL MACRO ((ATOM) (\\ATOMCELL ATOM \\DEF.HI))) (PUTPROPS \\VALCELL MACRO ((ATOM) (\\ATOMCELL ATOM \\VAL.HI))) (PUTPROPS \\PNAMECELL MACRO ((ATOM) (\\ATOMCELL ATOM \\PNAME.HI))) (PUTPROPS \\ATOMVALINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T ( SHOULDNT))))) (PUTPROPS \\ATOMDEFINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T ( SHOULDNT))))) (PUTPROPS \\ATOMPNAMEINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T ( SHOULDNT))))) (PUTPROPS \\ATOMPROPINDEX DMACRO ((X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") ( \\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (SHOULDNT))))) (PUTPROPS \\INDEXATOMPNAME DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol") (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) ( LOGAND X 65535))))) (T (* \; "New symbol") X)))) (PUTPROPS \\INDEXATOMVAL DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol") (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* \; "New symbol") X)))) (PUTPROPS \\INDEXATOMDEF DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol") (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* \; "New symbol") X)))) (PUTPROPS \\ATOMNUMBER DMACRO (= . \\LOLOC)) (GLOBALVARS |\\NxtPnByte| |\\CurPnPage| |\\NxtAtomPage| |\\AtomFrLst| |\\OneCharAtomBase| \\PNAMES.IN.BLOCKS? \\SCRATCHSTRING COMPILEATPUTDFLG) (RPAQQ \\PNAMELIMIT 255) (RPAQQ |\\CharsPerPnPage| 512) (CONSTANTS (\\PNAMELIMIT 255) (|\\CharsPerPnPage| 512)) (RPAQQ \\NEWATOM-PNAMEOFFSET 0) (RPAQQ \\NEWATOM-VALOFFSET 2) (RPAQQ \\NEWATOM-DEFOFFSET 4) (RPAQQ \\NEWATOM-PLISTOFFSET 6) (RPAQQ \\NEWATOM-TYPE# 21) (CONSTANTS (\\NEWATOM-PNAMEOFFSET 0) (\\NEWATOM-VALOFFSET 2) (\\NEWATOM-DEFOFFSET 4) ( \\NEWATOM-PLISTOFFSET 6) (\\NEWATOM-TYPE# 21)) (PUTPROPS \\MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) (\\BLT (\\ADDBASE DBASE DOFFSET) (\\ADDBASE SBASE SOFFSET) NWORDS))) (PUTPROP (QUOTE LLBASIC) (QUOTE IMPORTDATE) (IDATE "31-Jan-1998 09:55:50")) (ACCESSFNS STRINGP ((XREADONLY (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| DATUM) (|replace| ( ARRAY-HEADER READ-ONLY-P) |of| DATUM |with| NEWVALUE)) (XBASE ((OPENLAMBDA (STRING) (COND ((|fetch| ( ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-BASE STRING)) (T (|fetch| (ARRAY-HEADER BASE) |of| STRING)))) DATUM) ((OPENLAMBDA (STRING NV) (|replace| (ARRAY-HEADER INDIRECT-P) |of| STRING |with| NIL ) (|replace| (ARRAY-HEADER BASE) |of| STRING |with| NV) NV) DATUM NEWVALUE)) (TYP ((OPENLAMBDA (STRING ) (SELECTC (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-TYPE-NUMBER STRING)) (T ( |fetch| (ARRAY-HEADER TYPE-NUMBER) |of| STRING))) (%THIN-CHAR-TYPENUMBER \\ST.BYTE) ( %FAT-CHAR-TYPENUMBER \\ST.POS16) (SHOULDNT "Unknown type-number"))) DATUM) ((OPENLAMBDA (STRING NV) ( LET ((%NEW-TYPE-NUMBER (SELECTC NV (\\ST.BYTE %THIN-CHAR-TYPENUMBER) (\\ST.POS16 %FAT-CHAR-TYPENUMBER) (SHOULDNT "Unknown typ value")))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) ( %SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| STRING |with| %NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (LENGTH (|fetch| (ARRAY-HEADER FILL-POINTER) |of| DATUM) ((OPENLAMBDA (STRING NV) (|replace| (ARRAY-HEADER FILL-POINTER) |of| STRING |with| NV) (|replace| ( ARRAY-HEADER TOTAL-SIZE) |of| STRING |with| NV) (COND ((%GENERAL-ARRAY-P STRING) (|freplace| ( GENERAL-ARRAY DIMS) |of| STRING |with| (LIST NV)))) NV) DATUM NEWVALUE)) (OFFST ((OPENLAMBDA (STRING) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-OFFSET STRING)) (T (|fetch| ( ARRAY-HEADER OFFSET) |of| STRING)))) DATUM) ((OPENLAMBDA (STRING NV) (COND ((NOT (EQ 0 NV)) (|replace| (ARRAY-HEADER DISPLACED-P) |of| STRING |with| T))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%SET-ARRAY-OFFSET STRING NV)) (T (|replace| (ARRAY-HEADER OFFSET) |of| STRING |with| NV)))) DATUM NEWVALUE)) (* |;;| "The rest of these fields only appear when smashing") (XFLAGS (LOGAND ( |fetch| (ARRAY-HEADER FLAGS) |of| DATUM) 15) ((OPENLAMBDA (STRING) (|replace| (ARRAY-HEADER ADJUSTABLE-P) |of| STRING |with| NIL) (|replace| (ARRAY-HEADER DISPLACED-P) |of| STRING |with| NIL) ( |replace| (ARRAY-HEADER FILL-POINTER-P) |of| STRING |with| NIL) (|replace| (ARRAY-HEADER EXTENDABLE-P) |of| STRING |with| NIL)) DATUM))) (ACCESSFNS STRINGP ((ORIG ((OPENLAMBDA (STRING) 1) DATUM) (( OPENLAMBDA (STRING NV) (COND ((NOT (EQ NV 1)) (ERROR "Il:stringp's are always origin 1"))) NV) DATUM NEWVALUE)) (* \; "An inoperative field") (SUBSTRINGED ((OPENLAMBDA (STRING) NIL) DATUM) ((OPENLAMBDA ( STRING NV) (OR (NULL NV) (ERROR "Substringed field not supported"))) DATUM NEWVALUE)) (READONLY ( |ffetch| (STRINGP XREADONLY) |of| DATUM) (|freplace| (STRINGP XREADONLY) |of| DATUM |with| NEWVALUE)) (FATSTRINGP ((OPENLAMBDA (STRING) (EQ (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) ( %ARRAY-TYPE-NUMBER STRING)) (T (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| STRING))) %FAT-CHAR-TYPENUMBER )) DATUM) ((OPENLAMBDA (STRING NV) (LET ((%NEW-TYPE-NUMBER (COND (NV %FAT-CHAR-TYPENUMBER) (T %THIN-CHAR-TYPENUMBER)))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) ( %SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| STRING |with| %NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (BASE (|ffetch| (STRINGP XBASE) |of| DATUM) (|freplace| (STRINGP XBASE) |of| DATUM |with| NEWVALUE)))) (CREATE (|create| ONED-ARRAY BASE _ XBASE READ-ONLY-P _ XREADONLY STRING-P _ T DISPLACED-P _ (NOT (EQ OFFST 0)) TYPE-NUMBER _ (COND ((EQ TYP \\ST.POS16) %FAT-CHAR-TYPENUMBER) (T %THIN-CHAR-TYPENUMBER)) OFFSET _ OFFST FILL-POINTER _ LENGTH TOTAL-SIZE _ LENGTH)) (TYPE? (CL:STRINGP DATUM)) OFFST _ 0 TYP _ \\ST.BYTE LENGTH _ 0) (GLOBALVARS |\\OneCharAtomBase|) (PUTDEF (QUOTE \\NUMSTR) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING 128)))) (PUTDEF (QUOTE \\NUMSTR1) (QUOTE RESOURCES) (QUOTE (NEW (CONCAT)))) (PUTDEF (QUOTE \\PNAMESTRING) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING \\PNAMELIMIT NIL NIL \\FATPNAMESTRINGP)))) (RPAQQ \\FATPNAMESTRINGP T) (CONSTANTS (\\FATPNAMESTRINGP T)) (PUTPROPS \\PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* \; "For stuffing chars into resource \\PNAMESTRING") (\\PUTBASECHAR \\FATPNAMESTRINGP BASE OFFSET CODE))) (DEFOPTIMIZER FCHARACTER (NUM) (BQUOTE ((OPENLAMBDA (N) (COND ((IGREATERP N \\MAXTHINCHAR) (* \; "The character we're getting is NOT a thin character -- do it the hard way") (CHARACTER N)) (( IGREATERP N (CHARCODE 9)) (\\ADDBASE |\\OneCharAtomBase| (IDIFFERENCE N 10))) ((IGEQ N (CHARCODE 0)) ( IDIFFERENCE N (CHARCODE 0))) (T (* \; "The common case -- just add on the one-atom base.") (\\ADDBASE |\\OneCharAtomBase| N)))) (\\\, NUM)))) (I.S.OPR (QUOTE |inpname|) NIL (QUOTE (SUBPAIR (QUOTE ($$END $$BODY $$FATP $$BASE $$OFFSET)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (BQUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP |declare| (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET) |first| ( PROG NIL $$RETRY (COND ((STRINGP $$BODY) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$OFFSET (SUB1 (|ffetch| (STRINGP OFFST) |of| $$BODY))) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) (SETQ $$FATP (|ffetch| (STRINGP FATSTRINGP) |of| $$BODY))) ((LITATOM $$BODY) ( SETQ $$BASE (|ffetch| (LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) (SETQ $$FATP (|ffetch| (LITATOM FATPNAMEP) |of| $$BODY))) (T (SETQ $$BODY (MKSTRING $$BODY)) (GO $$RETRY)))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) ( GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET) ))))))) T) (I.S.OPR (QUOTE |inatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END $$FATP)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP) |first| ( SETQ $$BASE (|ffetch| (LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) (SETQ $$FATP (|ffetch| (LITATOM FATPNAMEP) |of| $$BODY)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET)))))))) T) (I.S.OPR (QUOTE |instring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE $$FATP)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP) |first| (SETQ $$OFFSET (SUB1 (|ffetch| (STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) (SETQ $$FATP (|ffetch| (STRINGP FATSTRINGP) |of| $$BODY)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET)))))))) T) (I.S.OPR (QUOTE |infatatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END) |first| (SETQ $$BASE (|ffetch| ( LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. ( \\GETBASEFAT $$BASE $$OFFSET)))))) T) (I.S.OPR (QUOTE |inthinatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END) |first| (SETQ $$BASE (|ffetch| ( LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. ( \\GETBASETHIN $$BASE $$OFFSET)))))) T) (I.S.OPR (QUOTE |infatstring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET $$BASE |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE) |first| (SETQ $$OFFSET (SUB1 (|ffetch| ( STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND ( IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\\GETBASEFAT $$BASE $$OFFSET)))))) T) (I.S.OPR (QUOTE |inthinstring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET $$BASE |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE) |first| (SETQ $$OFFSET (SUB1 (|ffetch| ( STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND ( IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\\GETBASETHIN $$BASE $$OFFSET)))))) T) (PUTPROPS \\CHARCODEP DMACRO (OPENLAMBDA (X) (* \; "used to also say (ILEQ X \\MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X) (IGEQ X 0)))) (PUTPROPS \\FATCHARCODEP DMACRO (OPENLAMBDA (X) (* \; "Used to also say (ILEQ X \\MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X) (IGREATERP X \\MAXTHINCHAR)))) (PUTPROPS \\THINCHARCODEP DMACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0) (ILEQ X \\MAXTHINCHAR)))) (PUTPROPS \\GETBASEFAT MACRO (= . \\GETBASE)) (PUTPROPS \\GETBASETHIN MACRO (= . \\GETBASEBYTE)) (PUTPROPS \\PUTBASEFAT MACRO (= . \\PUTBASE)) (PUTPROPS \\PUTBASETHIN MACRO (= . \\PUTBASEBYTE)) (PUTPROPS \\PUTBASECHAR MACRO (OPENLAMBDA (FATP BASE OFFSET CODE) (COND (FATP (\\PUTBASEFAT BASE OFFSET CODE)) (T (\\PUTBASETHIN BASE OFFSET CODE))))) (PUTPROPS \\GETBASECHAR MACRO ((FATP BASE N) (COND (FATP (\\GETBASEFAT BASE N)) (T (\\GETBASETHIN BASE N))))) (PUTPROPS \\CHARSET MACRO ((CHARCODE) (LRSH CHARCODE 8))) (PUTPROPS \\CHAR8CODE MACRO ((CHARCODE) (LOGAND CHARCODE 255))) (RPAQQ \\CHARMASK 255) (RPAQQ \\MAXCHAR 255) (RPAQQ \\MAXTHINCHAR 255) (RPAQQ \\MAXFATCHAR 65535) (RPAQQ \\MAXCHARSET 255) (RPAQQ NSCHARSETSHIFT 255) (RPAQQ \#STRINGPWORDS 4) (CONSTANTS (\\CHARMASK 255) (\\MAXCHAR 255) (\\MAXTHINCHAR 255) (\\MAXFATCHAR 65535) (\\MAXCHARSET 255 ) (NSCHARSETSHIFT 255) (\#STRINGPWORDS 4)) (PUTPROPS \\NATOMCHARS DMACRO ((AT) (|fetch| (LITATOM PNAMELENGTH) |of| AT))) (PUTPROPS \\NSTRINGCHARS DMACRO ((S) (|fetch| (STRINGP LENGTH) |of| S))) (PUTPROP (QUOTE LLCHAR) (QUOTE IMPORTDATE) (IDATE "11-Nov-2018 13:08:04")) (ACCESSFNS BF ((BFBLOCK (ADDSTACKBASE DATUM))) (* \; "basic frame pointer") (BLOCKRECORD BFBLOCK (( FLAGS BITS 3) (NIL BITS 3) (RESIDUAL FLAG) (* \; "true if this is not a full BF") (PADDING BITS 1) ( USECNT BITS 8) (IVAR WORD))) (TYPE? (IEQ (|fetch| (BF FLAGS) |of| DATUM) \\STK.BF)) (ACCESSFNS BF (( NARGS (IDIFFERENCE (FOLDLO (IDIFFERENCE DATUM (|fetch| (BF IVAR) |of| DATUM)) WORDSPERCELL) (|fetch| ( BF PADDING) |of| DATUM))) (SIZE (IPLUS 2 (IDIFFERENCE DATUM (|fetch| (BF IVAR) |of| DATUM)))) (CHECKED (AND (|type?| BF DATUM) (|for| I |from| (|fetch| (BF IVAR) |of| DATUM) |to| (IDIFFERENCE DATUM 2) |by| 2 |always| (IEQ \\STK.NOTFLAG (|fetch| (BF FLAGS) |of| I)))))))) (ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* \; "frame extension index") (BLOCKRECORD FXBLOCK (( FLAGS BITS 3) (* \; "= \\STK.FX") (FAST FLAG) (NIL FLAG) (INCALL FLAG) (* \; "set when fncall microcode has to punt") (VALIDNAMETABLE FLAG) (* \; "if on, NAMETABLE field is filled in. If off, is same as FNHEADER") (NOPUSH FLAG) (* \; "when returning to this frame, don't push a value. Set by interrupt code") (USECNT BITS 8) (\#ALINK WORD) (* \; "low bit is SLOWP") (FNHEADER FULLXPOINTER) (NEXTBLOCK WORD) (PC WORD) (NAMETABLE# FULLXPOINTER) (\#BLINK WORD) (\#CLINK WORD))) (BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE) (NIL BYTE) (NIL BITS 15) (* \; "most of the bits of #ALINK") (SLOWP FLAG) (* \; "if on, then BLINK and CLINK fields are valid. If off, they are implicit") (NIL FULLXPOINTER 2) ( NAMETABHI WORD) (NAMETABLO WORD))) (TYPE? (IEQ (|fetch| (FX FLAGS) |of| DATUM) \\STK.FX)) (ACCESSFNS FX ((NAMETABLE (COND ((|fetch| (FX VALIDNAMETABLE) |of| DATUM) (|fetch| (FX NAMETABLE#) |of| DATUM)) ( T (|fetch| (FX FNHEADER) |of| DATUM))) (PROGN (|replace| (FX FAST) |of| DATUM |with| NIL) (|replace| ( FX NAMETABLE#) |of| DATUM |with| NEWVALUE) (|replace| (FX VALIDNAMETABLE) |of| DATUM |with| T))) ( FRAMENAME (|fetch| (FNHEADER FRAMENAME) |of| (|fetch| (FX NAMETABLE) |of| DATUM))) (INVALIDP (EQ DATUM 0)) (* \; "true when A/CLink points at nobody, i.e. FX is bottom of stack") (FASTP (NOT (|fetch| (FX SLOWP) |of| DATUM)) (PROGN (CHECK (NULL NEWVALUE)) (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| ( FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX \#ALINK) |of| DATUM)) (|replace| (FX SLOWP) |of| DATUM |with| T))))) (BLINK (COND ((|fetch| (FX FASTP) |of| DATUM) (|fetch| (FX DUMMYBF) |of| DATUM)) (T (|fetch| (FX \#BLINK) |of| DATUM))) (PROGN (|replace| (FX \#BLINK) |of| DATUM |with| NEWVALUE) (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX \#ALINK) |of| DATUM)) (|replace| (FX SLOWP) |of| DATUM |with| T))))) (CLINK (IDIFFERENCE (COND ((|fetch| (FX FASTP) |of| DATUM) (|fetch| ( FX \#ALINK) |of| DATUM)) (T (|fetch| (FX \#CLINK) |of| DATUM))) \\#ALINK.OFFSET) (PROGN (|replace| (FX \#CLINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET)) (COND ((|fetch| (FX FASTP) |of| DATUM) ( |replace| (FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX SLOWP) |of| DATUM |with| T))))) (ALINK (IDIFFERENCE (FLOOR (|fetch| (FX \#ALINK) |of| DATUM) WORDSPERCELL) \\#ALINK.OFFSET) (PROGN (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX \#ALINK) |of| DATUM)))) (|replace| (FX \#ALINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET ( SUB1 WORDSPERCELL))))) (ACLINK (SHOULDNT) (PROGN (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)))) (|replace| (FX \#CLINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET)) (|replace| (FX \#ALINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET (SUB1 WORDSPERCELL))))) (* \; "replaces A & C Links at once more efficiently than separately") (DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL)) (* |;;| "This is either an actual BF or \"residual\" BF that provides enough BF to find its IVAR slot. This means that when a FX is copied, the cell preceding the FX is copied too." ) (IVAR (|fetch| (BF IVAR) |of| (|fetch| (FX DUMMYBF) |of| DATUM))) (CHECKED (AND (|type?| FX DATUM) ( OR (IEQ (|fetch| (FX DUMMYBF) |of| DATUM) (|fetch| (FX BLINK) |of| DATUM)) (AND (|fetch| (BF RESIDUAL) |of| (|fetch| (FX DUMMYBF) |of| DATUM)) (IEQ (|fetch| (BF IVAR) |of| (|fetch| (FX DUMMYBF) |of| DATUM )) (|fetch| (BF IVAR) |of| (|fetch| (FX BLINK) |of| DATUM))))))) (FIRSTPVAR (IPLUS DATUM (|fetch| (FX FXSIZE) |of| T))) (* \; "stack offset of PVAR0") (FXSIZE (PROGN 10)) (* \; "fixed overhead from flags thru clink") (PADDING (PROGN 4)) (* \; "doublecell of garbage for microcode use") (FIRSTTEMP (IPLUS (|fetch| (FX FIRSTPVAR) |of| DATUM) ( |fetch| (FX NPVARWORDS) |of| DATUM) (|fetch| (FX PADDING) |of| DATUM))) (* \; "note that NPVARWORDS is obtained from the FNHEADER") (SIZE (IDIFFERENCE (|fetch| (FX NEXTBLOCK) |of| DATUM) DATUM))))) (ACCESSFNS FSB (* |;;| "FREE STACK BLOCK -- ") (* |;;| " A piece of stack space that's free.") (* |;;| "The first word contains 120000Q") (* |;;| "The 2nd word is the size of the block, in words.") (( FSBBLOCK (ADDSTACKBASE DATUM)) (CHECKED (IEQ (|fetch| (FSB FLAGWORD) |of| DATUM) \\STK.FSB.WORD))) ( BLOCKRECORD FSBBLOCK ((FLAGS BITS 3) (DUMMY BITS 13) (SIZE WORD))) (BLOCKRECORD FSBBLOCK ((FLAGWORD WORD) (SIZE WORD))) (* \; "free stack block") (TYPE? (IEQ (|fetch| (FSB FLAGS) |of| DATUM) \\STK.FSB)) ) (ACCESSFNS STK ((STKBLOCK (ADDSTACKBASE DATUM))) (* \; "unspecified stack block") (BLOCKRECORD STKBLOCK ((FLAGS BITS 3))) (BLOCKRECORD STKBLOCK ((FLAGWORD WORD)))) (RPAQQ \\#ALINK.OFFSET 10) (CONSTANTS \\#ALINK.OFFSET) (GLOBALVARS \\PENDINGINTERRUPT \\KBDSTACKBASE \\MISCSTACKBASE \\STACKOVERFLOW) (PUTPROPS \\MYALINK DMACRO (NIL ((OPCODES MYALINK)))) (PUTPROPS ADDSTACKBASE DMACRO (= . STACKADDBASE)) (PUTPROPS STACKADDBASE DMACRO ((N) (VAG2 \\STACKHI N))) (PUTPROPS STACKGETBASE DMACRO ((N) (\\GETBASE (STACKADDBASE N) 0))) (PUTPROPS STACKGETBASEPTR DMACRO ((N) (\\GETBASEPTR (STACKADDBASE N) 0))) (PUTPROPS STACKPUTBASE DMACRO ((N V) (\\PUTBASE (STACKADDBASE N) 0 V))) (PUTPROPS STACKPUTBASEPTR DMACRO ((N V) (\\PUTBASEPTR (STACKADDBASE N) 0 V))) (PUTPROPS \\MISCAPPLY* MACRO ((FN ARG1 ARG2) (UNINTERRUPTABLY (|replace| (IFPAGE MISCSTACKFN) |of| |\\InterfacePage| |with| FN) (|replace| (IFPAGE MISCSTACKARG1) |of| |\\InterfacePage| |with| ARG1) ( |replace| (IFPAGE MISCSTACKARG2) |of| |\\InterfacePage| |with| ARG2) (\\CONTEXTSWITCH |\\MiscFXP|) ( |fetch| (IFPAGE MISCSTACKRESULT) |of| |\\InterfacePage|)))) (BLOCKRECORD STACKP ((STACKP0 WORD) (EDFXP WORD)) (BLOCKRECORD STACKP ((STACKPOINTER FULLXPOINTER))) ( TYPE? (STACKP DATUM))) (RPAQQ STACKTYPES (\\STK.GUARD \\STK.FX \\STK.BF \\STK.NOTFLAG \\STK.FSB \\STK.FLAGS.SHIFT ( \\STK.FSB.WORD (LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (\\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT)) (\\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT)))) (RPAQQ \\STK.GUARD 7) (RPAQQ \\STK.FX 6) (RPAQQ \\STK.BF 4) (RPAQQ \\STK.NOTFLAG 0) (RPAQQ \\STK.FSB 5) (RPAQQ \\STK.FLAGS.SHIFT 13) (RPAQ \\STK.FSB.WORD (LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (RPAQ \\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT)) (RPAQ \\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT)) (CONSTANTS \\STK.GUARD \\STK.FX \\STK.BF \\STK.NOTFLAG \\STK.FSB \\STK.FLAGS.SHIFT (\\STK.FSB.WORD ( LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (\\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT)) ( \\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT))) (RPAQQ |\\StackAreaSize| 768) (RPAQ |\\InitStackSize| (ITIMES |\\StackAreaSize| 12)) (CONSTANTS |\\StackAreaSize| (|\\InitStackSize| (ITIMES |\\StackAreaSize| 12))) (RPAQQ \\MAXSAFEUSECOUNT 200) (CONSTANTS \\MAXSAFEUSECOUNT) (BLOCKRECORD NAMETABLESLOT ((VARTYPE BYTE) (VAROFFSET BYTE))) (BLOCKRECORD FVARSLOT ((BINDLO WORD) (BINDHI WORD)) (ACCESSFNS FVARSLOT ((LOOKEDUP (EVENP (|fetch| BINDLO |of| DATUM))) (BINDINGPTR (\\VAG2 (|fetch| BINDHI |of| DATUM) (|fetch| BINDLO |of| DATUM)) ( PROGN (|replace| BINDLO |of| DATUM |with| (\\LOLOC NEWVALUE)) (|replace| BINDHI |of| DATUM |with| ( \\HILOC NEWVALUE))))))) (BLOCKRECORD PVARSLOT ((PVHI BITS 4) (PVVALUE XPOINTER)) (ACCESSFNS PVARSLOT ((BOUND (EQ (|fetch| ( PVARSLOT PVHI) |of| DATUM) 0) (|if| (NULL NEWVALUE) |then| (|replace| (PVARSLOT PVHI) |of| DATUM |with| 255) |else| (ERROR "Illegal replace" NEWVALUE)))))) (BLOCKRECORD STKTEMPSLOT ((STKTMPHI BITS 4) (VALUE XPOINTER)) (ACCESSFNS STKTEMPSLOT ((BINDINGPTRP ( NEQ (|fetch| STKTMPHI |of| DATUM) 0))))) (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* \; "Value stored in high half is one's complement of number of values bound") (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535)))))) (RPAQQ \\NT.IVAR 0) (RPAQQ \\NT.PVAR 128) (RPAQQ \\NT.FVAR 192) (CONSTANTS \\NT.IVAR \\NT.PVAR \\NT.FVAR) (PUTPROP (QUOTE LLSTK) (QUOTE IMPORTDATE) (IDATE " 6-Jan-1993 18:07:37")) (PUTPROPS WORDCONTENTS BYTEMACRO ((PTR) (\\GETBASE PTR 0))) (PUTPROPS SETWORDCONTENTS BYTEMACRO ((PTR N) (\\PUTBASE PTR 0 N))) (PUTPROPS WORDOFFSET BYTEMACRO ((PTR N) (\\ADDBASE PTR N))) (PUTPROPS \\RELEASECPAGE MACRO ((STREAM) (PROGN (* \; "Must be under an UNINTERRUPTABLY !") (COND (( |fetch| CBUFDIRTY |of| STREAM) (\\SETIODIRTY STREAM (|fetch| CPAGE |of| STREAM)) (|replace| CBUFDIRTY |of| STREAM |with| NIL))) (|replace| CBUFSIZE |of| STREAM |with| 0) (|replace| CBUFPTR |of| STREAM |with| NIL)))) (PUTPROP (QUOTE PMAP) (QUOTE IMPORTDATE) (IDATE " 3-Feb-2002 14:11:02")) (PUTPROPS ADDREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\\ADDREF PTR)))) (PUTPROPS \\ADDREF DMACRO ((X) ((OPCODES GCREF 0) X))) (PUTPROPS DELETEREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\\DELREF PTR)))) (PUTPROPS \\DELREF DMACRO ((X) ((OPCODES GCREF 1) X))) (PUTPROPS SCANREF MACRO (= . \\STKREF)) (PUTPROPS \\STKREF DMACRO ((X) ((OPCODES GCREF 2) X))) (PUTPROPS UNSCANREF MACRO ((PTR) (\\HTFIND PTR 3))) (PUTPROPS CREATEREF MACRO (= . \\CREATEREF)) (PUTPROPS \\CREATEREF MACRO (OPENLAMBDA (PTR) (PROG1 (\\DELREF PTR) (.INCREMENT.ALLOCATION.COUNT. 1))) ) (PUTPROPS .INCREMENT.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \\RECLAIM.COUNTDOWN) ) (AND \\RECLAIM.COUNTDOWN (COND ((IGREATERP \\RECLAIM.COUNTDOWN N) (SETQ \\RECLAIM.COUNTDOWN ( IDIFFERENCE \\RECLAIM.COUNTDOWN N))) (T (SETQ \\RECLAIM.COUNTDOWN) (\\DORECLAIM)))))) (PUTPROPS .CHECK.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \\RECLAIM.COUNTDOWN)) ( AND \\RECLAIM.COUNTDOWN (COND ((NOT (IGREATERP \\RECLAIM.COUNTDOWN N)) (SETQ \\RECLAIM.COUNTDOWN) ( \\DORECLAIM)))))) (PUTPROPS \\GCDISABLED MACRO (NIL (PROGN (DECLARE (GLOBALVARS \\GCDISABLED)) \\GCDISABLED))) (BLOCKRECORD HTOVERFLOW ((CASE BITS 4) (PTR XPOINTER)) (ACCESSFNS HTOVERFLOW ((CLEAR NIL (\\PUTBASEPTR DATUM 0 NIL))))) (BLOCKRECORD GC ((CNT BITS 15) (STKBIT FLAG) (HIBITS BITS 15) (LINKP FLAG) (NXTPTR FIXP)) (BLOCKRECORD GC ((STKCNT WORD))) (ACCESSFNS GC ((EMPTY (EQ 0 (\\GETBASEFIXP DATUM 0)) (\\PUTBASEFIXP DATUM 0 0)) ( CONTENTS (\\GETBASEFIXP DATUM 0) (\\PUTBASEFIXP DATUM 0 NEWVALUE)) (LINKPTR (LOGAND (\\GETBASEFIXP DATUM 0) -2) (\\PUTBASEFIXP DATUM 0 (LOGOR NEWVALUE 1)))))) (BLOCKRECORD HTCOLL ((* |;;| "An entry in the GC collision table. NEXTFREE is initialized to 2 by INITGC, as part of the MAKEINIT." ) (FREEPTR FIXP) (* \; "The GC table entry") (NEXTFREE FIXP) (* \; "If the entry is in use, points to the next entry in this collision chain. If not, offset (in 1/2-entries) of the next free one on the chain." ))) (PUTPROP (QUOTE LLGC) (QUOTE IMPORTDATE) (IDATE "19-Oct-1994 12:30:11")) (PUTPROPS \\SYNCODE DMACRO (OPENLAMBDA (TABLE CHAR) (CHECK (|type?| CHARTABLE TABLE)) (* \; "0 is either NONE.TC, REAL.CCE, or OTHER.RC") (COND ((IGREATERP CHAR \\MAXTHINCHAR) (OR (AND (|fetch| (CHARTABLE NSCHARHASH) |of| TABLE) (GETHASH CHAR (|fetch| (CHARTABLE NSCHARHASH) |of| TABLE))) 0)) (T (\\GETBASEBYTE TABLE CHAR))))) (PUTPROPS \\SETSYNCODE DMACRO (LAMBDA (TABLE CHAR CODE) (CHECK (|type?| CHARTABLE TABLE)) (* \; "0 is REAL.CCE, NONE.TC, OTHER.RC") (COND ((ILEQ CHAR \\MAXTHINCHAR) (\\PUTBASEBYTE TABLE CHAR CODE)) (T (\\SETFATSYNCODE TABLE CHAR CODE))))) (DATATYPE CHARTABLE ((CHARSET0 256 BYTE) (NSCHARHASH FULLPOINTER))) (RPAQQ CCECHOMODES (REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)) (RPAQQ REAL.CCE 0) (RPAQQ IGNORE.CCE 8) (RPAQQ SIMULATE.CCE 16) (RPAQQ INDICATE.CCE 24) (CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE) (RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC)) (RPAQQ NONE.TC 0) (RPAQQ EOL.TC 1) (RPAQQ CHARDELETE.TC 2) (RPAQQ WORDDELETE.TC 6) (RPAQQ WORDSEPR.TC 7) (RPAQQ LINEDELETE.TC 3) (RPAQQ RETYPE.TC 4) (RPAQQ CTRLV.TC 5) (CONSTANTS NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC) (ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24)) (TERMCLASS (LOGAND DATUM 7))) (* \; "We assume that values are appropriately shifted") (CREATE (LOGOR CCECHO TERMCLASS))) (DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL ( CONTROLFLG FLAG) (ECHOFLG FLAG)) TERMSA _ (|create| CHARTABLE)) (PUTPROPS \\GETREADMACRODEF MACRO ((C TBL) (GETHASH C (|fetch| READMACRODEFS |of| TBL)))) (PUTPROPS \\GTREADTABLE MACRO (ARGS (COND ((LITATOM (CAR ARGS)) (SUBPAIR (QUOTE (X . FLG)) ARGS (QUOTE (SELECTQ X ((NIL T) (\\DTEST *READTABLE* (QUOTE READTABLEP))) (\\GTREADTABLE1 X . FLG))))) (T (QUOTE IGNOREMACRO))))) (PUTPROPS \\GTREADTABLE1 DMACRO (ARGS (COND ((NULL (CDR ARGS)) (LIST (QUOTE \\DTEST) (CAR ARGS) (QUOTE (QUOTE READTABLEP)))) (T (QUOTE IGNOREMACRO))))) (RPAQQ MACROBIT 8) (RPAQQ BREAKBIT 16) (RPAQQ STOPATOMBIT 32) (RPAQQ ESCAPEBIT 64) (RPAQQ INNERESCAPEBIT 4) (CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT) (RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2)))) (RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (RPAQ WAKEUPMASK (LOGOR MACROBIT 2)) (CONSTANTS (CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2))) (RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) (ALONE.RMC (LOGOR MACROBIT 1)))) (RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (RPAQ FIRST.RMC (LOGOR MACROBIT 0)) (RPAQ ALONE.RMC (LOGOR MACROBIT 1)) (CONSTANTS (ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) ( ALONE.RMC (LOGOR MACROBIT 1))) (RPAQQ READCLASSES ((OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) ( LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)))) (RPAQQ OTHER.RC 0) (RPAQ SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (RPAQ BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (RPAQ STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (RPAQ LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RPAQ RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (RPAQ LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RPAQ RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (RPAQ ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (RPAQ MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (RPAQ PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)) (CONSTANTS (OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (LEFTPAREN.RC ( LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) ( LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))) (RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0)))) (RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2)) (RPAQ NONIMMEDIATE.RMW (LOGOR MACROBIT 0)) (CONSTANTS (IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0))) (RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT) (NOESC.RME 0))) (RPAQ ESC.RME ESCAPEBIT) (RPAQQ NOESC.RME 0) (CONSTANTS (ESC.RME ESCAPEBIT) (NOESC.RME 0)) (ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT)) (ESCQUOTE (BITTEST DATUM ESCAPEBIT)) (STOPATOM (BITTEST DATUM STOPATOMBIT)) (INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT))) ( MACROCONTEXT (LOGAND DATUM CONTEXTMASK)) (MACROP (BITTEST DATUM MACROBIT)) (WAKEUP (LOGAND DATUM WAKEUPMASK)) (BREAK (BITTEST DATUM BREAKBIT)))) (RECORD READMACRODEF (MACROTYPE . MACROFN)) (DATATYPE READTABLEP ((READSA POINTER) (* \; "A CHARTABLE defining syntax of each char") ( READMACRODEFS POINTER) (* \; "A hash table associating macro chars with macro definitions") ( READMACROFLG FLAG) (* \; "True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)") (ESCAPEFLG FLAG) (* \; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)" ) (COMMONLISP FLAG) (* \; "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules") (NUMBERBASE BITS 5) (* \; "Not used") (CASEINSENSITIVE FLAG) (* \; "If true, unescaped lowercase chars are converted to uppercase in symbols") (COMMONNUMSYNTAX FLAG) (* \; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers" ) (USESILPACKAGE FLAG) (* \; "If true, IL:READ ignores *PACKAGE* and reads in the IL package") (NIL 5 FLAG) (DISPATCHMACRODEFS POINTER) (* \; "An a-list of dispatching macro char and its dispatch definitions") (HASHMACROCHAR BYTE) (* \; "The character code used in this read table for the # dispatch macro") (ESCAPECHAR BYTE) (* \; "The character code used in this read table for single escape") (MULTESCAPECHAR BYTE) (* \; "The character code used in this read table for multiple escape") (PACKAGECHAR BYTE) (* \; "The character code used in this read table for package delimiter") (READTBLNAME POINTER) (* \; "The canonical 'name' of this read table")) READSA _ (|create| CHARTABLE)) (PUTPROP (QUOTE ATBL) (QUOTE IMPORTDATE) (IDATE "12-Feb-2021 16:52:07")) (DATATYPE STREAM ((* |;;| "First 8 words are fixed for BIN, BOUT opcodes. Used to require length of whole datatype be multiple of 4, but Dolphin dead now." ) (COFFSET WORD) (* \; "Offset in CPPTR of next bin or bout") (CBUFSIZE WORD) (* \; "Offset past last byte in that buffer") (PEEKEDCHARP FLAG) (* \; "if true, PEEKEDCHAR contains value of recent call to unread-char") (ACCESSBITS BITS 3) (* \; "What kind of access file is open for (read, write, append)") (CBUFPTR POINTER) (* \; "Pointer to current buffer") (BYTESIZE BYTE) (* \; "Byte size of stream, always 8 for now") (CHARSET BYTE) (* \; "the current character set for this stream. If 255, stream is not runcoded, so read-char consumes two bytes every time" ) (PEEKEDCHAR WORD) (* \; "value of unread-char call") (CHARPOSITION WORD) (* \; "Used by POSITION etc.") (CBUFMAXSIZE WORD) (* \; "on output, the size of the physical buffer--can't extend beyond this") (* |;;| "-------- Above fields (8 words) potentially known to microcode. --------") (NONDEFAULTDATEFLG FLAG) (REVALIDATEFLG FLAG) (MULTIBUFFERHINT FLAG) (* \; "True if stream likes to read and write more than one buffer at a time") (USERCLOSEABLE FLAG) (* \; "Can be closed by CLOSEF; NIL for terminal, dribble...") (FULLFILENAME POINTER) (* \; "Name by which file is known to user") (BINABLE FLAG) (* \; "BIN punts unless this bit on") (BOUTABLE FLAG) (* \; "BOUT punts unless this bit on") (EXTENDABLE FLAG) (* \; "BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512") (CBUFDIRTY FLAG) (* \; "true if BOUT has sullied the current buffer") (DEVICE POINTER) (* \; "FDEV of this guy") (USERVISIBLE FLAG) (* \; "Listed by OPENP; NIL for terminal, dribble ...") (EOLCONVENTION BITS 2) (* \; "End-of-line convention") (NOTXCCS FLAG) (* \; "True if the character encoding format is not XCCS.") ( VALIDATION POINTER) (* \; "A number somehow identifying file, used to determine if file has changed in our absence") (CPAGE POINTER) (* \; "CPAGE,,COFFSET constitutes current file pointer for most randaccess streams") (EPAGE POINTER) (EOFFSET WORD) (* \; "Page, byte offset of eof") (LINELENGTH WORD) (* \; "LINELENGTH of stream, or -1 for no line length") (* |;;| "----Following are device-specific fields----") (* |;;| "Available for device-specific uses, NOT for application use.") (F1 POINTER) (F2 POINTER) (F3 POINTER) (F4 POINTER) (F5 POINTER) (FW6 WORD) (FW7 WORD) (FW8 WORD) (FW9 WORD) (F10 POINTER) (* |;;| "----Following only filled in for open streams----") (STRMBINFN POINTER) (* \; "Either the BIN fn from the FDEV, or a trap") (STRMBOUTFN POINTER) (* \; "Either the BIN fn from the FDEV, or a trap") (OUTCHARFN POINTER) (* \; "Called by \\OUTCHAR, the normal character printer.") (ENDOFSTREAMOP POINTER) (* \; "Called if EOF and we try to read.") (OTHERPROPS POINTER) (* \; "PROP LIST for holding other info.") ( IMAGEOPS POINTER) (* \; "Image operations vector") (IMAGEDATA POINTER) (* \; "Image instance variables--format depends on IMAGEOPS value") (BUFFS POINTER) (* \; "Buffer chain for pmapped streams") (MAXBUFFERS WORD) (* \; "Max # of buffers the system will allocate.") (LASTCCODE WORD) (* \; "After READ, RATOM, etc, the charcode that will be returned (as a character) by LASTC. If there is none, this field is 65535." ) (EXTRASTREAMOP POINTER) (* \; "For use of applications programs, not devices")) (BLOCKRECORD STREAM ((NIL 2 WORD) (UCODEFLAGS1 BITS 1) (* |;;| "respecification of access bits:") (RANDOMWRITEABLE FLAG) ( * \; "File open for output (access = OUTPUT or BOTH)") (APPENDABLE FLAG) (* \; "File open for append (OUTPUT or APPEND or BOTH)") (READABLE FLAG) (* \; "File open for read (READ or BOTH)") (NIL POINTER))) (BLOCKRECORD STREAM ((NIL 4 WORD) (NIL BITS 14) ( * |;;| "JIS character encoding format specific, overrides CHARSET field.") (IN.KANJIIN FLAG) (* \; "True if input stream is in Kanji-in mode.") (OUT.KANJIIN FLAG) (* \; "True if output stream is in Kanji-in mode."))) (ACCESSFNS STREAM ((ACCESS \\GETACCESS \\SETACCESS) ( FULLNAME (OR (|fetch| (STREAM FULLFILENAME) |of| DATUM) DATUM)) (NAMEDP (AND (|fetch| (STREAM FULLFILENAME) |of| DATUM) T)))) (ACCESSFNS STREAM (EXTERNALFORMAT (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)) (LET ((PROPS (|ffetch| (STREAM OTHERPROPS) |of| DATUM) )) (|freplace| (STREAM NOTXCCS) |of| DATUM |with| T) (COND (PROPS (LISTPUT PROPS (QUOTE EXTERNALFORMAT ) NEWVALUE)) (T (|freplace| (STREAM OTHERPROPS) |of| DATUM |with| (LIST (QUOTE EXTERNALFORMAT) NEWVALUE)))) (|freplace| (STREAM OUTCHARFN) |of| DATUM |with| (|ffetch| (EXTERNALFORMAT FILEOUTCHARFN) |of| NEWVALUE)) (AND (|ffetch| (EXTERNALFORMAT EOLVALID) |of| NEWVALUE) (|freplace| (STREAM EOLCONVENTION) |of| DATUM |with| (|ffetch| (EXTERNALFORMAT EOL) |of| NEWVALUE)))))) (ACCESSFNS STREAM (EXTERNALFORMAT.NAME (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT.NAME)) ( LET ((PROPS (|ffetch| (STREAM OTHERPROPS) |of| DATUM)) (NAME (COND ((LITATOM NEWVALUE) NEWVALUE) (T ( MKATOM NEWVALUE))))) (|freplace| (STREAM NOTXCCS) |of| DATUM |with| T) (COND (PROPS (LISTPUT PROPS ( QUOTE EXTERNALFORMAT.NAME) NAME)) (T (|freplace| (STREAM OTHERPROPS) |of| DATUM |with| (LIST (QUOTE EXTERNALFORMAT.NAME) NAME))))))) (ACCESSFNS STREAM (INCCODEFN (LET ((XFMT (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch| ( EXTERNALFORMAT INCCODEFN) |of| XFMT))))) (ACCESSFNS STREAM (PEEKCCODEFN (LET ((XFMT (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch| (EXTERNALFORMAT PEEKCCODEFN) |of| XFMT))))) (ACCESSFNS STREAM (BACKCHARFN (LET ((XFMT (LISTGET ( |ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch| (EXTERNALFORMAT BACKCHARFN) |of| XFMT))))) (ACCESSFNS STREAM (FILEOUTCHARFN (|ffetch| (STREAM OUTCHARFN) |of| DATUM))) (SYNONYM CBUFPTR (CPPTR)) USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ |NoBits| CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE ( GLOBALVARS \\STREAM.DEFAULT.MAXBUFFERS)) \\STREAM.DEFAULT.MAXBUFFERS) CHARPOSITION _ 0 LINELENGTH _ ( LET NIL (DECLARE (GLOBALVARS FILELINELENGTH)) FILELINELENGTH) OUTCHARFN _ (FUNCTION \\FILEOUTCHARFN) ENDOFSTREAMOP _ (FUNCTION \\EOSERROR) IMAGEOPS _ \\NOIMAGEOPS EOLCONVENTION _ (SELECTQ (SYSTEMTYPE) (D CR.EOLC) (VAX LF.EOLC) (JERICHO CRLF.EOLC) CR.EOLC) STRMBINFN _ (FUNCTION \\STREAM.NOT.OPEN) STRMBOUTFN _ (FUNCTION \\STREAM.NOT.OPEN) LASTCCODE _ 65535 NOTXCCS _ NIL) (PUTPROPS STREAMOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) ( QUOTE QUOTE)) (LIST (QUOTE |fetch|) (CADAR ARGS) (QUOTE |of|) (CADR ARGS))) (T (HELP "STREAMOP - OPNAME not quoted:" ARGS))) (CDDR ARGS))))) (RPAQQ |AppendBit| 2) (RPAQQ |NoBits| 0) (RPAQQ |ReadBit| 1) (RPAQQ |WriteBit| 4) (RPAQ |OutputBits| (LOGOR |AppendBit| |WriteBit|)) (RPAQ |BothBits| (LOGOR |ReadBit| |OutputBits|)) (RPAQQ \\NORUNCODE 255) (CONSTANTS |AppendBit| |NoBits| |ReadBit| |WriteBit| (|OutputBits| (LOGOR |AppendBit| |WriteBit|)) ( |BothBits| (LOGOR |ReadBit| |OutputBits|)) \\NORUNCODE) (PUTPROPS |TestMasked| MACRO ((BITS MASK) (NEQ (LOGAND BITS MASK) 0))) (PUTPROPS APPENDABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |AppendBit|))) (PUTPROPS APPENDONLY MACRO ((STREAM) (EQ (|fetch| ACCESSBITS |of| STREAM) |AppendBit|))) (PUTPROPS DIRTYABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) (CONSTANT (LOGOR |AppendBit| |WriteBit|))))) (PUTPROPS OPENED MACRO ((STREAM) (NEQ (|fetch| ACCESSBITS |of| STREAM) |NoBits|))) (PUTPROPS OVERWRITEABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |WriteBit|))) (PUTPROPS READABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |ReadBit|))) (PUTPROPS READONLY MACRO ((STREAM) (EQ (|fetch| ACCESSBITS |of| STREAM) |ReadBit|))) (PUTPROPS WRITEABLE MACRO ((STREAM) (OR (OVERWRITEABLE STREAM) (AND (APPENDABLE STREAM) (\\EOFP STREAM ))))) (PUTPROPS \\RUNCODED MACRO (OPENLAMBDA (STREAM) (* |;;| "returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented" ) (* \; "note that neq is ok since charsets are known to be SMALLP's") (NEQ (|fetch| CHARSET |of| STREAM) \\NORUNCODE))) (RPAQQ EOLCONVENTIONS ((CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2))) (RPAQQ CR.EOLC 0) (RPAQQ LF.EOLC 1) (RPAQQ CRLF.EOLC 2) (CONSTANTS (CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2)) (PUTPROPS FDEVOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS)) ) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (|fetch| (FDEV ( \\\, (CADR OPNAME))) |of| (\\\, METHOD-DEVICE)) (\\\,@ TAIL)))) (T (ERROR "OPNAME not quoted: " OPNAME )))))) (PUTPROPS \\RECOGNIZE-HACK DMACRO (ARGS (LET ((NAME (CAR ARGS)) (RECOG (CADR ARGS)) (DEVICE (CADDR ARGS))) (BQUOTE (|if| (|type?| STREAM (\\\, NAME)) |then| (\\\, NAME) |else| (FDEVOP (QUOTE GETFILENAME) (\\\, DEVICE) (\\\, NAME) (\\\, RECOG) (\\\, DEVICE))))))) (DATATYPE FDEV ((RESETABLE FLAG) (* \; "Obsolete") (RANDOMACCESSP FLAG) (NODIRECTORIES FLAG) ( PAGEMAPPED FLAG) (* \; "True if i/o handled by pmap routines") (FDBINABLE FLAG) (* \; "Copied as a microcode flag for INPUT streams formed on this device") (FDBOUTABLE FLAG) (FDEXTENDABLE FLAG) (BUFFERED FLAG) (* \; "True implies that the device supports the BIN & BOUT uCode conventions, and implements the GETNEXTBUFFER method" ) (DEVICENAME POINTER) (* \; "Identifying name somehow") (REMOTEP FLAG) (* \; "true if device not local to machine") (SUBDIRECTORIES FLAG) (* \; "true if device has real subdirectories") (INPUT-INDIRECTED FLAG) (* \; "True for devices that indirect their input stream. Method INPUTSTREAM fetches it") ( OUTPUT-INDIRECTED FLAG) (* \; "True for devices that indirect their output stream. Method OUTPUTSTREAM fetches it") (DEVICEINFO POINTER) (* \; "arbitrary device-specific info stored here") (OPENFILELST POINTER) (* \; "Default place to keep list of streams open on this device") (* |;;| "-----Rest of record consists of device \"methods\"-----") (* |;;| "-----Following fields required of all devices-----") (HOSTNAMEP POINTER) (* \; "(hostname {device}) => T if hostname is valid. If device is given, return a FDEV for this {new} host, or T to use existing device" ) (EVENTFN POINTER) (* \; "(device event), called before/after logout, sysout, makesys") (* |;;| "-----Following fields required of all named devices, e.g., ones that open files-----") ( DIRECTORYNAMEP POINTER) (* \; "(host/dir) => true if directory exists on host") (OPENFILE POINTER) (* \; "(name access recog otherinfo device) => new stream open on this device, or NIL if name not found") (CLOSEFILE POINTER) (* \; "(stream) => closes stream, returns it") (REOPENFILE POINTER) (* \; "(name access recog otherinfo device stream) like openfile, but called after logout to revalidate file, so optionally uses info in old stream to keep this opening like the previous" ) (GETFILENAME POINTER) (* \; "(name recog device) => full file name") (DELETEFILE POINTER) (* \; "(name) => deletes file so named, returning name, or NIL on failure. RECOG=OLDEST") (GENERATEFILES POINTER) (* \; "(device pattern) => generator object for files matching pattern. Car of object is generator function, cdr is arbitrary state. Generator fn returns next file, or NIL when finished" ) (RENAMEFILE POINTER) (* \; "(olddevice oldfile newdevice newfile) to rename file on this (olddevice) to a potentially different device." ) (OPENP POINTER) (* \; "(name access dev) => stream if name is open for access, or all open streams if name = NIL") ( REGISTERFILE POINTER) (* \; "(stream dev) => registers stream on its device") (UNREGISTERFILE POINTER) (* \; "(stream dev) => unregisters a stream from its device") (FREEPAGECOUNT POINTER) (* \; "(host/dir dev) => # of free pages on host/dir") (MAKEDIRECTORY POINTER) (* \; "(host/dir dev)") ( CHECKFILENAME POINTER) (* \; "(name dev) => name if it is well-formed file name for dev") (HOSTALIVEP POINTER) (* \; "(host dev) => true if host is alive, i.e., responsive; only defined if REMOTEP is true") ( BREAKCONNECTION POINTER) (* \; "(host fastp dev) => closes connections to host") (* |;;| "-----The following are required methods for operating on open streams-----") (BIN POINTER) (* \; "(stream) => next byte of input") (BOUT POINTER) (* \; "(stream byte) output byte to stream") (PEEKBIN POINTER) (* \; "(stream) => next byte without advancing position in stream") (READCHAR POINTER) (* \; "(stream) => next input char") (WRITECHAR POINTER) (* \; "(stream char) => writes char to stream") ( PEEKCHAR POINTER) (UNREADCHAR POINTER) (READP POINTER) (* \; "(stream flag) => T if there is input available from stream right now") (EOFP POINTER) (* \; "(stream) => T if BIN would signal eof.") (BLOCKIN POINTER) (* \; "(stream buffer byteoffset nbytes)") (BLOCKOUT POINTER) (* \; "(stream buffer byteoffset nbytes)") (FORCEOUTPUT POINTER) (* \; "(stream waitForFinish) flushes out to device anything that is buffered awaiting transmission") ( GETFILEINFO POINTER) (* \; "(stream/name attribute device) => value of attribute for open stream or name of closed file") ( SETFILEINFO POINTER) (* \; "(stream/name attribute newvalue device) sets attribute of open stream or closed file of given name") (CHARSETFN POINTER) (* \; "(stream charset) => access function for the charset slot, for benefit of indirect streams. See IMCHARSET for changing it on a file." ) (INPUTSTREAM POINTER) (* \; "(stream) => indirected input stream") (OUTPUTSTREAM POINTER) (* \; "(stream) => indirected output stream") (* |;;| "-----Following are required of random-access streams-----") (GETFILEPTR POINTER) (GETEOFPTR POINTER) (SETFILEPTR POINTER) (BACKFILEPTR POINTER) (* \; "(stream) backs up `fileptr' by one. Stream is only required to be able to do this once, i.e. one-character buffer suffices" ) (SETEOFPTR POINTER) (* \; "(stream length) => truncates or lengthens stream to indicated length") ( LASTC POINTER) (* \; "Should be possible only if RANDOMACCESSP") (* |;;| "-----Following used for buffered streams-----") (GETNEXTBUFFER POINTER) (* \; "(stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next. whatfor is READ or WRITE. Can cause EOF error unless noerrorflg" ) (RELEASEBUFFER POINTER) (* \; "(stream) => Does whatever appropriate when CBUFPTR is released") (* |;;| "-----Following used for pagemapped streams-----") (READPAGES POINTER) (* \; "(stream firstpage# buflist) => # of bytes read, starting at firstpage#, reading into buflist, a list of buffers or a single buffer (the usual case)" ) (WRITEPAGES POINTER) (* \; "(stream firstpage# buflist) writes from buflist to stream starting at firstpage# of stream") ( TRUNCATEFILE POINTER) (* \; "(stream page offset) make stream's eof be at page,offset, discarding anything after it") (* |;;| "-----For window system, argh-----") (WINDOWOPS POINTER) (* \; "window system operations") (WINDOWDATA POINTER) (* \; "data for window systems") (* |;;| "-----For any stream (here to not recompile everything)-----") (READCHARCODE POINTER) (* \; "Read a character code from the stream (cf BIN for bytes).")) DIRECTORYNAMEP _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) READP _ (FUNCTION \\GENERIC.READP) SETFILEPTR _ (FUNCTION \\IS.NOT.RANDACCESSP) GETFILEPTR _ (FUNCTION \\ILLEGAL.DEVICEOP) GETEOFPTR _ (FUNCTION \\IS.NOT.RANDACCESSP) EOFP _ (FUNCTION \\ILLEGAL.DEVICEOP) BLOCKIN _ (FUNCTION \\GENERIC.BINS) BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS) RENAMEFILE _ (FUNCTION \\GENERIC.RENAMEFILE) FORCEOUTPUT _ ( FUNCTION NILL) REGISTERFILE _ (FUNCTION NILL) OPENP _ (FUNCTION NILL) UNREGISTERFILE _ (FUNCTION NILL) READCHAR _ (FUNCTION \\GENERIC.READCHAR) WRITECHAR _ (FUNCTION \\GENERIC.WRITECHAR) PEEKCHAR _ ( FUNCTION \\GENERIC.PEEKCHAR) UNREADCHAR _ (FUNCTION \\GENERIC.UNREADCHAR) CHARSETFN _ (FUNCTION \\GENERIC.CHARSET) BREAKCONNECTION _ (FUNCTION NILL) READCHARCODE _ (FUNCTION \\GENERIC.READCCODE)) (RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE)) (DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (* \; "If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream.") (EOL BITS 2) (NIL BITS 1) (INCCODEFN POINTER) (* \; "Called with two arguments -- STREAM and COUNTP") ( PEEKCCODEFN POINTER) (* \; "Called with three arguments -- STREAM, NOERROR and COUNTP") (BACKCHARFN POINTER) (* \; "Called with two arguments -- STREAM and COUNTP") (FILEOUTCHARFN POINTER) (* \; "Called with two arguments -- STREAM and CHARCODE")) EOLVALID _ NIL) (PUTPROPS \\OUTCHAR DMACRO (OPENLAMBDA (STREAM CHARCODE) (STREAMOP (QUOTE OUTCHARFN) STREAM STREAM CHARCODE))) (PUTPROPS \\DEVICE-OPEN-STREAMS MACRO (ARGS (LET ((DEVICE (CAR ARGS))) (BQUOTE (FDEVOP (QUOTE OPENP) ( \\\, DEVICE) NIL NIL (\\\, DEVICE)))))) (PUTPROPS \\CONVERT-PATHNAME DMACRO (OPENLAMBDA (PATHNAME?) (* |;;| "Coerce pathnames to Interlisp strings, for the benefit of antediluvian Interlisp-D file fns") ( CL:TYPECASE PATHNAME? (PATHNAME (INTERLISP-NAMESTRING PATHNAME?)) (T PATHNAME?)))) (DEFOPTIMIZER ACCESS-CHARSET (STREAM &OPTIONAL NEWVALUE) (BQUOTE ((OPENLAMBDA (STRM) (FDEVOP (QUOTE CHARSETFN) (|fetch| (STREAM DEVICE) |of| STRM) STRM (\\\, NEWVALUE))) (\\\, STREAM)))) (PUTPROPS \\DECFILEPTR MACRO ((STREAM X) (\\INCFILEPTR STREAM (IMINUS X)))) (PUTPROPS \\GETFILEPTR MACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE GETFILEPTR) (|fetch| DEVICE |of| STRM) STRM))) (PUTPROPS \\SIGNEDWIN MACRO ((STREAM) (SIGNED (\\WIN STREAM) BITSPERWORD))) (PUTPROPS \\SIGNEDWOUT MACRO ((STREAM N) (\\WOUT STREAM (UNSIGNED N BITSPERWORD)))) (PUTPROPS \\WIN MACRO (OPENLAMBDA (STREAM) (|create| WORD HIBYTE _ (\\BIN STREAM) LOBYTE _ (\\BIN STREAM)))) (PUTPROPS \\WOUT MACRO (OPENLAMBDA (STREAM W) (\\BOUT STREAM (|fetch| HIBYTE |of| W)) (\\BOUT STREAM ( |fetch| LOBYTE |of| W)))) (PUTPROPS \\BINS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKIN) (|fetch| (STREAM DEVICE) |of| STRM) STRM BASE OFF NBYTES))) (PUTPROPS \\BOUTS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKOUT) (|fetch| ( STREAM DEVICE) |of| STRM) STRM BASE OFF NBYTES))) (PUTPROPS \\EOFP BYTEMACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE EOFP) (|fetch| (STREAM DEVICE) |of| STRM) STRM))) (PUTPROPS SIZE.FROM.LENGTH MACRO (LAMBDA (LEN) (DECLARE (LOCALVARS LEN)) (AND LEN (FOLDHI LEN BYTESPERPAGE)))) (RPAQQ |BitsPerByte| 8) (RPAQ |ByteOffsetSize| (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) (RPAQQ |WordsPerPage| 256) (CONSTANTS |BitsPerByte| (|ByteOffsetSize| (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) |WordsPerPage|) (RPAQ \\MAXFILEPTR (SUB1 (LLSH 1 30))) (CONSTANTS (\\MAXFILEPTR (SUB1 (LLSH 1 30)))) (ACCESSFNS BYTEPTR ((PAGE (FOLDLO DATUM BYTESPERPAGE)) (OFFSET (MOD DATUM BYTESPERPAGE))) (TYPE? (AND (FIXP DATUM) (IGEQ DATUM 0) (ILEQ DATUM \\MAXFILEPTR))) (CREATE (IPLUS (UNFOLD PAGE BYTESPERPAGE) OFFSET))) (PUTPROP (QUOTE FILEIO) (QUOTE IMPORTDATE) (IDATE "13-Aug-2020 11:43:08")) (BLOCKRECORD FIXP ((HINUM WORD) (LONUM WORD)) (CREATE (CREATECELL \\FIXP)) (TYPE? (EQ (NTYPX DATUM) \\FIXP))) (RPAQQ MAX.SMALL.INTEGER 65535) (RPAQQ MAX.POS.HINUM 32767) (CONSTANTS (MAX.SMALL.INTEGER 65535) (MAX.POS.HINUM 32767)) (PUTPROPS .UNBOX. MACRO (ARGS (LET ((ARG-FORM (CAR ARGS)) (HIGH-VAR (CADR ARGS)) (LOW-VAR (CADDR ARGS) ) (BIGNUM-FORM (CADDDR ARGS))) (BQUOTE (PROG NIL UBLP (SELECTC (NTYPX (\\\, ARG-FORM)) (\\FIXP (SETQ ( \\\, HIGH-VAR) (|ffetch| (FIXP HINUM) |of| (\\\, ARG-FORM))) (SETQ (\\\, LOW-VAR) (|ffetch| (FIXP LONUM) |of| (\\\, ARG-FORM)))) (\\SMALLP (COND ((ILEQ 0 (\\\, ARG-FORM)) (SETQ (\\\, HIGH-VAR) 0) ( SETQ (\\\, LOW-VAR) (\\\, ARG-FORM))) (T (SETQ (\\\, HIGH-VAR) 65535) (SETQ (\\\, LOW-VAR) (\\LOLOC ( \\\, ARG-FORM)))))) (\\FLOATP (SETQ (\\\, ARG-FORM) (\\FIXP.FROM.FLOATP (\\\, ARG-FORM))) (GO UBLP)) ( COND ((TYPENAMEP (\\\, ARG-FORM) (QUOTE RATIO)) (SETQ (\\\, ARG-FORM) (IQUOTIENT (CL::RATIO-NUMERATOR (\\\, ARG-FORM)) (CL::RATIO-DENOMINATOR (\\\, ARG-FORM)))) (GO UBLP)) (\\\,@ (COND (BIGNUM-FORM ( BQUOTE (((CL:INTEGERP (\\\, ARG-FORM)) (\\\, BIGNUM-FORM))))) (T (BQUOTE (((CL:INTEGERP (\\\, ARG-FORM )) (\\ILLEGAL.ARG (\\\, ARG-FORM)))))))) (T (CL::%NOT-NONCOMPLEX-NUMBER-ERROR (\\\, ARG-FORM)))))))))) (PUTPROPS .NEGATE. MACRO ((HY LY) (COND ((EQ 0 LY) (AND (NEQ HY 0) (SETQ HY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY))))) (T (SETQ HY (IDIFFERENCE MAX.SMALL.INTEGER HY)) (SETQ LY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY))))))) (PUTPROPS .LLSH1. MACRO ((HI LO) (* \; "shift the pair left one, assuming no overflow") (SETQ HI (LLSH HI 1)) (SETQ LO (LLSH (COND ((IGREATERP LO MAX.POS.HINUM) (|add| HI 1) (LOGAND LO MAX.POS.HINUM)) (T LO)) 1)))) (PUTPROPS .LRSH1. MACRO ((HI LO) (SETQ LO (LRSH LO 1)) (COND ((NEQ (LOGAND HI 1) 0) (SETQ LO (IPLUS LO \\SIGNBIT)))) (SETQ HI (LRSH HI 1)))) (PUTPROPS .BOXIPLUS. MACRO (OPENLAMBDA (X Y) (PROG ((HX (\\GETBASE X 0)) (LX (\\GETBASE X 1)) HY LY) ( .UNBOX. Y HY LY) (SETQ HX (COND ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY)) (IDIFFERENCE HX ( ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY)))) (T (IPLUS HX HY)))) (* |Add| |high| |parts|) (\\PUTBASE X 1 (COND ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY)) (* |Carry| |into| |high| |part.|) (SETQ HX ( COND ((EQ HX MAX.SMALL.INTEGER) 0) (T (ADD1 HX)))) (IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY)))) (T (IPLUS LX LY)))) (\\PUTBASE X 0 HX) (RETURN X)))) (PUTPROPS |PutUnboxed| DMACRO (= . \\PUTFIXP)) (PUTPROP (QUOTE LLARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 18:47:56")) (PUTPROPS POLYEVAL DMACRO ((X COEFFS DEGREE) (* \; "execute the POLYEVAL opcode on the value X, the array COEFFS with degree DEGREE") (\\FLOATBOX (( OPCODES UBFLOAT3 0) (\\FLOATUNBOX X) (|fetch| (ARRAYP BASE) |of| COEFFS) DEGREE)))) (BLOCKRECORD FLOATP ((SIGNBIT BITS 1) (EXPONENT BITS 8) (HIFRACTION BITS 7) (LOFRACTION BITS 16)) ( BLOCKRECORD FLOATP ((HIWORD WORD) (LOWORD WORD))) (BLOCKRECORD FLOATP ((NIL BITS 9) (LONGFRACTION BITS 23))) (BLOCKRECORD FLOATP ((FLOATCONTENTS BITS 32))) (BLOCKRECORD FLOATP ((NIL BITS 1) ( HIWORDNOSIGNBIT BITS 15))) (CREATE (\\FLOATBOX (\\VAG2 (LOGOR (LLSH SIGNBIT (PLUS 7 8)) (LLSH EXPONENT 7) HIFRACTION) LOFRACTION))) LOFRACTION _ 0 HIFRACTION _ 0 EXPONENT _ 0 SIGNBIT _ 0 (ACCESSFNS FLOATP ((EXP (LOGAND (LRSH (\\HILOC (\\FLOATUNBOX DATUM)) 7) 255)) (HIFRAC (LOGAND (\\HILOC (\\FLOATUNBOX DATUM)) 127))))) (RPAQQ MAX.DIGITS.ACCURACY 9) (CONSTANTS (MAX.DIGITS.ACCURACY 9)) (PUTPROPS \\CALLER.ARGS MACRO (X (LET ((ARGS (CAR X)) (FORMS (CDR X))) (BQUOTE (PROGN (\\SLOWRETURN) ( LET ((AL (\\MYALINK)) NEXT (\\\,@ (|for| VAR |in| ARGS |collect| (COND ((LISTP VAR) (LIST (CAR VAR) 0) ) (T VAR))))) (DECLARE (\\\,@ (|for| VAR |in| ARGS |when| (LISTP VAR) |collect| (BQUOTE (TYPE (\\\, ( SELECTQ (CADR VAR) ((FLOATING FLOATP) (CADR VAR)) (HELP))) (\\\, (CAR VAR))))))) (SETQ NEXT (|fetch| ( FX NEXTBLOCK) |of| AL)) (\\\,@ (|for| X |in| (REVERSE ARGS) |collect| (LET ((FORMS (BQUOTE ( \\.GETBASE32 \\STACKSPACE (SETQ NEXT (IDIFFERENCE NEXT WORDSPERCELL)))))) (COND ((LISTP X) (BQUOTE ( SETQ (\\\, (CAR X)) (\\FLOATBOX (\\\, FORMS))))) (T (BQUOTE (SETQ (\\\, X) (\\\, FORMS)))))))) ( \\MAKEFREEBLOCK NEXT (TIMES (\\\, (LENGTH ARGS)) WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| AL |with| NEXT) (PROGN (\\\,@ FORMS)))))))) (PUTPROP (QUOTE LLFLOAT) (QUOTE IMPORTDATE) (IDATE "16-May-1990 19:26:51")) (DEFOPTIMIZER FONTPROP (&REST ARGS) (SELECTQ (AND (EQ (CAADR ARGS) (QUOTE QUOTE)) (CADADR ARGS)) ( ASCENT (LIST (QUOTE FONTASCENT) (CAR ARGS))) (DESCENT (LIST (QUOTE FONTDESCENT) (CAR ARGS))) (HEIGHT ( LIST (QUOTE FONTHEIGHT) (CAR ARGS))) (QUOTE IGNOREMACRO))) (DATATYPE FONTCLASS ((PRETTYFONT# BYTE) DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME)) (DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) (FONTFAMILY POINTER) (FONTSIZE POINTER) (FONTFACE POINTER) (|\\SFAscent| WORD) (|\\SFDescent| WORD) (|\\SFHeight| WORD) (ROTATION WORD) (FBBOX SIGNEDWORD) (FBBOY SIGNEDWORD) (FBBDX SIGNEDWORD) (FBBDY SIGNEDWORD) (|\\SFLKerns| POINTER) ( |\\SFRWidths| POINTER) (FONTDEVICESPEC POINTER) (* \; "Holds the spec by which the font is known to the printing device, if coercion has been done") ( OTHERDEVICEFONTPROPS POINTER) (* \; "For individual devices to hang special information") (FONTSCALE POINTER) (\\SFFACECODE BITS 8) (FONTAVGCHARWIDTH WORD) (* \; "Set in FONTCREATE, used to fix up the linelength when DSPFONT is called") (FONTIMAGEWIDTHS POINTER) ( * \; "This is the image width, as opposed to the advanced width; initial hack for accents, kerning. Fields is referenced by FONTCREATE." ) (FONTCHARSETVECTOR POINTER) (* \; "A 256-pointer block, with one pointer per 'character set' --each group of 256 character codes. Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset." ) (FONTEXTRAFIELD2 POINTER)) FONTCHARSETVECTOR _ (\\CREATEFONTCHARSETVECTOR)) (RECORD FONTFACE (WEIGHT SLOPE EXPANSION) (ACCESSFNS ((COLOR (CDDDR DATUM) (RPLACD (CDDR DATUM) NEWVALUE)) (BACKCOLOR (COND ((CDDDR DATUM) (CAR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) ( RPLACD (CDDR DATUM) (LIST NIL NIL)))) (RPLACA (CDDDR DATUM) NEWVALUE))) (FORECOLOR (COND ((CDDDR DATUM ) (CADR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) (RPLACD (CDDR DATUM) (LIST NIL NIL)))) ( RPLACA (CDR (CDDDR DATUM)) NEWVALUE))))) WEIGHT _ (QUOTE MEDIUM) SLOPE _ (QUOTE REGULAR) EXPANSION _ ( QUOTE REGULAR) (TYPE? LISTP)) (DATATYPE CHARSETINFO (WIDTHS (* \; "The advance-width of each character, an array indexed by charcode. Usually the same as the imagewidth, but can differ for accents, kerns kerns. This is what should be used for stringwidth calculations." ) OFFSETS (* \; "Offset of each character into the image bitmap; X value of left edge") IMAGEWIDTHS ( * \; "imagewidths is not automagically allocated since it is not always needed") CHARSETBITMAP (* \; "Bitmap containing the character images, indexed by OFFSETS") YWIDTHS (CHARSETASCENT WORD) (* \; "Max ascent for all characters in this CHARSET") (CHARSETDESCENT WORD) (* \; "Max descent for all characters in this CHARSET") LEFTKERN) WIDTHS _ (\\CREATECSINFOELEMENT) OFFSETS _ (\\CREATECSINFOELEMENT)) (PUTPROPS FONTASCENT MACRO ((FONTSPEC) (|ffetch| |\\SFAscent| |of| (\\GETFONTDESC FONTSPEC)))) (PUTPROPS FONTDESCENT MACRO ((FONTSPEC) (|ffetch| |\\SFDescent| |of| (\\GETFONTDESC FONTSPEC)))) (PUTPROPS FONTHEIGHT MACRO ((FONTSPEC) (|ffetch| |\\SFHeight| |of| (\\GETFONTDESC FONTSPEC)))) (PUTPROPS \\FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) (\\GETBASE OFFSETSBLOCK CHAR8CODE))) (PUTPROPS \\FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET) (\\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET))) (PUTPROPS \\FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) (\\GETBASE WIDTHSBLOCK CHAR8CODE))) (PUTPROPS \\FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\\PUTBASE WIDTHSBLOCK INDEX WIDTH))) (PUTPROPS \\FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE) (\\FGETWIDTH (|ffetch| (CHARSETINFO WIDTHS) |of| (\\GETCHARSETINFO (\\CHARSET CHARCODE) FONTDESC)) (\\CHAR8CODE CHARCODE)))) (PUTPROPS \\FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) (\\FSETWIDTH (|ffetch| ( CHARSETINFO WIDTHS) |of| (\\GETCHARSETINFO (\\CHARSET CHARCODE) FONTDESC)) (\\CHAR8CODE CHARCODE) WIDTH))) (PUTPROPS \\FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE) (\\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE)) ) (PUTPROPS \\FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\\PUTBASE WIDTHSBLOCK INDEX WIDTH))) (PUTPROPS \\GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?) (* |;;| "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC. If NIL, then creates the required charset." ) (* |;;| "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") (OR (\\GETBASEPTR (|ffetch| FONTCHARSETVECTOR |of| FONTDESC) (UNFOLD CHARSET 2)) (\\CREATECHARSET CHARSET FONTDESC NOSLUG?)))) (PUTPROPS \\CREATECSINFOELEMENT MACRO (NIL (\\ALLOCBLOCK (FOLDHI (IPLUS \\MAXTHINCHAR 3) WORDSPERCELL) ))) (PUTPROPS \\CREATEFONTCHARSETVECTOR MACRO (NIL (* \; "Allocates a block for the character set records" ) (\\ALLOCBLOCK (ADD1 \\MAXCHARSET) T))) (DEFMACRO \\CREATEKERNELEMENT NIL (BQUOTE (CL:MAKE-ARRAY (IPLUS \\MAXTHINCHAR 3) :ELEMENT-TYPE (QUOTE (SIGNED-BYTE 16)) :INITIAL-ELEMENT 0))) (DEFMACRO \\FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE) (BQUOTE (CL:SETF (CL:AREF (\\\, LEFTKERNBLOCK ) (\\\, INDEX)) (\\\, KERNVALUE)))) (DEFMACRO \\FGETLEFTKERN (LEFTKERNBLOCK CHAR8CODE) (BQUOTE (CL:AREF (\\\, LEFTKERNBLOCK) (\\\, CHAR8CODE)))) (RPAQQ \\MAXNSCHAR 65535) (CONSTANTS (\\MAXNSCHAR 65535)) (PUTPROP (QUOTE FONT) (QUOTE IMPORTDATE) (IDATE "12-Feb-2021 16:52:07")) (BLOCKRECORD KEYACTION ((* |;;| "KEYACTION Table: For interpreting keystrokes. Stored as a 8-cell block of untyped pointer hunk storage." ) FLAGS (* \; "Flag byte per key# (one for down-transtion, 1 for up-.) to describe whether lockshifting occrrs, you ignore the transition, etc." ) CODES (* \; "Table of character codes generated by each key when no shift key is pressed.") SHIFTCODES (* \; "Table of character codes generated by each key when the shift key is pressed.") ARMED (* \; "Not sure...") INTERRUPTLIST (* \; "List of armed interrupts?") ALTGRAPHCODES (* \; "Table of codes to be generated when the ALT-GRAPH key is pressed.") DEADKEYLIST (* \; "Block of dead-key handlers, with the nominal up-transition fields filled by the shifted-case tables. Each \"table\" is an ALIST of orignal code => accented code. no entry means punt the accent.." )) FLAGS _ (\\ALLOCBLOCK (FOLDHI (IPLUS \\NKEYS \\NKEYS) BYTESPERCELL)) CODES _ (\\ALLOCBLOCK (FOLDHI (PLUS \\NKEYS \\NKEYS) WORDSPERCELL)) SHIFTCODES _ (\\ALLOCBLOCK (FOLDHI (PLUS \\NKEYS \\NKEYS) WORDSPERCELL)) ARMED _ (\\ALLOCBLOCK (FOLDHI (ADD1 \\MAXTHINCHAR) BITSPERCELL)) ALTGRAPHCODES _ ( \\ALLOCBLOCK (FOLDHI (PLUS \\NKEYS \\NKEYS) WORDSPERCELL)) DEADKEYLIST _ (\\ALLOCBLOCK (PLUS \\NKEYS \\NKEYS \\NKEYS \\NKEYS) T) (CREATE (\\ALLOCBLOCK 7 PTRBLOCK.GCT)) (TYPE? (AND (\\BLOCKDATAP DATUM) ( IGEQ (\\#BLOCKDATACELLS DATUM) 5) (OR (NULL (FETCH (KEYACTION INTERRUPTLIST) OF DATUM)) (LISTP (FETCH INTERRUPTLIST OF DATUM))) (\\BLOCKDATAP (FETCH (KEYACTION FLAGS) DATUM)) (\\BLOCKDATAP (FETCH ( KEYACTION CODES) DATUM)) (\\BLOCKDATAP (FETCH (KEYACTION ARMED) DATUM))))) (RPAQQ \\NKEYS 112) (CONSTANTS \\NKEYS) (DEFOPTIMIZER KEYDOWNP (KEYNAME) (BQUOTE (\\NEWKEYDOWNP (\\KEYNAMETONUMBER (\\\, KEYNAME))))) (PUTPROPS XKEYDOWNP MACRO ((KEYNAME) (KEYDOWNP1 (\\KEYNAMETONUMBER KEYNAME)))) (PUTPROPS KEYDOWNP1 MACRO (OPENLAMBDA (KEYNUMBER) (DECLARE (GLOBALVARS \\EM.KBDAD0 \\EM.KBDAD1 \\EM.KBDAD2 \\EM.KBDAD3 \\EM.UTILIN \\EM.KBDAD4 \\EM.KBDAD5)) (PROG NIL (RETURN (EQ 0 (LOGAND (LRSH ( LLSH 1 15) (PROGN (* (IMOD KEYNUMBER BITSPERWORD) - GETD |cause| IMOD |and| BITSPERWORD |not| |exported| |to| |user|) (LOGAND KEYNUMBER 15))) (\\GETBASE (SELECTQ (PROGN (* (FOLDLO KEYNUMBER BITSPERWORD) GETD |follows| |since| FOLDLO |and| BITSPERWORD |not| |exported| |to| |user|) (LRSH KEYNUMBER 4)) (0 \\EM.KBDAD0) (1 \\EM.KBDAD1) (2 \\EM.KBDAD2) (3 \\EM.KBDAD3) (4 \\EM.UTILIN) (5 (OR \\EM.KBDAD4 (RETURN))) (6 (OR \\EM.KBDAD5 (RETURN))) (RETURN)) 0))))))) (PUTPROPS \\NEWKEYDOWNP MACRO ((KEYNUMBER) (EQ 0 (\\GETBASEBIT \\LASTKEYSTATE KEYNUMBER)))) (GLOBALVARS \\KEYBOARD.DEVICE \\KEYBOARD.STREAM) (RPAQQ HARDCURSORHEIGHT 16) (RPAQQ HARDCURSORWIDTH 16) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD) (PUTPROPS \\SETMOUSEXY MACRO ((XPOS YPOS) (PROGN (SELECTC \\MACHINETYPE (\\DAYBREAK ( |\\DoveMisc.SetMousePosition| XPOS YPOS)) (\\MAIKO (SUBRCALL SETMOUSEXY XPOS YPOS)) (\\DANDELION (|do| (PROGN (|replace| (IOPAGE NEWMOUSEX) |of| \\IOPAGE |with| XPOS) (|replace| (IOPAGE NEWMOUSEY) |of| \\IOPAGE |with| YPOS)) |repeatuntil| (ILESSP (|fetch| (IOPAGE NEWMOUSESTATE) |of| \\IOPAGE) 32768)) (* \; "smash position until mouse says it is not busy") (|replace| (IOPAGE NEWMOUSEX) |of| \\IOPAGE |with| XPOS) (|replace| (IOPAGE NEWMOUSEY) |of| \\IOPAGE |with| YPOS) (|replace| (IOPAGE NEWMOUSESTATE ) |of| \\IOPAGE |with| 32768)) NIL) (PROGN (\\PUTBASE \\EM.MOUSEX 0 XPOS) (\\PUTBASE \\EM.MOUSEY 0 YPOS))))) (GLOBALVARS \\EM.MOUSEX \\EM.MOUSEY \\EM.CURSORX \\EM.CURSORY \\EM.UTILIN \\EM.REALUTILIN \\EM.KBDAD0 \\EM.KBDAD1 \\EM.KBDAD2 \\EM.KBDAD3 \\EM.KBDAD4 \\EM.KBDAD5 \\EM.DISPINTERRUPT \\EM.DISPLAYHEAD \\EM.CURSORBITMAP \\MACHINETYPE \\DEFAULTKEYACTION \\COMMANDKEYACTION \\CURRENTKEYACTION \\PERIODIC.INTERRUPT \\PERIODIC.INTERRUPT.FREQUENCY) (PUTPROP (QUOTE LLKEY) (QUOTE IMPORTDATE) (IDATE "12-Feb-2021 16:52:07")) (DATATYPE PILOTBBT ((PBTDESTLO WORD) (PBTDESTHI WORD) (PBTDESTBIT WORD) (PBTDESTBPL SIGNEDWORD) ( PBTSOURCELO WORD) (PBTSOURCEHI WORD) (PBTSOURCEBIT WORD) (PBTSOURCEBPL SIGNEDWORD) (PBTWIDTH WORD) ( PBTHEIGHT WORD) (PBTFLAGS WORD) (NIL 5 WORD)) (BLOCKRECORD PILOTBBT ((NIL 7 WORD) (NIL BITS 4) ( PBTGRAYOFFSET BITS 4) (PBTGRAYWIDTHLESSONE BITS 4) (PBTGRAYHEIGHTLESSONE BITS 4) (NIL 2 WORD) ( PBTBACKWARD FLAG) (PBTDISJOINT FLAG) (PBTDISJOINTITEMS FLAG) (PBTUSEGRAY FLAG) (PBTSOURCETYPE BITS 1) (PBTOPERATION BITS 2) (NIL BITS 9))) (ACCESSFNS PILOTBBT ((PBTSOURCE (\\VAG2 (|fetch| PBTSOURCEHI |of| DATUM) (|fetch| PBTSOURCELO |of| DATUM)) (PROGN (|replace| PBTSOURCEHI |of| DATUM |with| (\\HILOC NEWVALUE)) (|replace| PBTSOURCELO |of| DATUM |with| (\\LOLOC NEWVALUE)))) (PBTDEST (\\VAG2 (|fetch| PBTDESTHI |of| DATUM) (|fetch| PBTDESTLO |of| DATUM)) (PROGN (|replace| PBTDESTHI |of| DATUM |with| ( \\HILOC NEWVALUE)) (|replace| PBTDESTLO |of| DATUM |with| (\\LOLOC NEWVALUE)))))) (SYSTEM)) (DATATYPE \\DISPLAYDATA (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET |DDDestination| |DDClippingRegion| DDFONT |DDSlowPrintingCase| DDWIDTHSCACHE DDOFFSETSCACHE DDCOLOR DDLINEFEED |DDRightMargin| |DDLeftMargin| |DDScroll| DDOPERATION DDSOURCETYPE (|DDClippingLeft| WORD) ( |DDClippingRight| WORD) (|DDClippingBottom| WORD) (|DDClippingTop| WORD) (NIL WORD) (DDHELDFLG FLAG) ( XWINDOWHINT XPOINTER) (DDPILOTBBT POINTER) DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS DDEOLFN DDPAGEFULLFN |DDTexture| DDMICAXPOS DDMICAYPOS DDMICARIGHTMARGIN DDCHARSET (DDCHARSETASCENT WORD) (DDCHARSETDESCENT WORD) DDCHARHEIGHTDELTA (DDSPACEWIDTH WORD)) DDPILOTBBT _ (|create| PILOTBBT PBTDISJOINT _ T) |DDLeftMargin| _ 0 |DDRightMargin| _ SCREENWIDTH DDXPOSITION _ 0 DDYPOSITION _ 0 DDXOFFSET _ 0 DDYOFFSET _ 0 |DDClippingRegion| _ (|create| REGION) |DDDestination| _ |ScreenBitMap| DDXSCALE _ 1 DDYSCALE _ 1 |DDTexture| _ 0 (ACCESSFNS ((DDFOREGROUNDCOLOR (PROG ((VAL (|fetch| (\\DISPLAYDATA DDCOLOR) |of| DATUM))) (OR (FIXP VAL) (BITMAPP VAL) (AND (NULL VAL) 1) (CAR VAL) (MAXIMUMCOLOR ( BITSPERPIXEL (|fetch| (\\DISPLAYDATA |DDDestination|) |of| DATUM)))))) (DDBACKGROUNDCOLOR (OR (|fetch| (\\DISPLAYDATA |DDTexture|) |of| DATUM) 0)))) (SYSTEM)) (RECORD DISPLAYSTATE (ONOFF)) (RECORD DISPLAYINFO (DITYPE DIWIDTH DIHEIGHT DIBITSPERPIXEL DIWSOPS)) (PUTPROPS \\GETDISPLAYDATA MACRO (ARGS (COND ((CADR ARGS) (SUBPAIR (QUOTE (STRM STRMVAR)) ARGS (QUOTE (\\DTEST (|fetch| (STREAM IMAGEDATA) |of| (SETQ STRMVAR (\\OUTSTREAMARG STRM))) (QUOTE \\DISPLAYDATA)) ))) (T (SUBST (CAR ARGS) (QUOTE STRM) (QUOTE (\\DTEST (|fetch| (STREAM IMAGEDATA) |of| (\\OUTSTREAMARG STRM)) (QUOTE \\DISPLAYDATA)))))))) (PUTPROPS \\BITMASK MACRO ((N) (\\WORDELT BITMASKARRAY (LOGAND N 15)))) (PUTPROPS \\4BITMASK MACRO ((N) (\\WORDELT 4BITMASKARRAY (LOGAND N 3)))) (PUTPROPS \\NOTBITMASK MACRO ((N) (DECLARE (GLOBALVARS NOTBITMASKARRAY)) (\\WORDELT NOTBITMASKARRAY ( LOGAND N 15)))) (PUTPROPS \\NOT4BITMASK MACRO ((N) (\\WORDELT NOT4BITMASKARRAY (LOGAND N 3)))) (GLOBALVARS BITMASKARRAY NOTBITMASKARRAY 4BITMASKARRAY NOT4BITMASKARRAY) (RPAQQ WORDMASK 65535) (CONSTANTS (WORDMASK 65535)) (PUTPROPS \\INVALIDATEDISPLAYCACHE MACRO ((DISPLAYDATA) (* |This| |marks| |the| |character-printing| |caches| |of| |the| |displaystream| |as| |invalid.| |Needed| |when| |the| |font| |or| Y |position| |changes|) (|freplace| (\\DISPLAYDATA DDCHARSET) |of| DISPLAYDATA |with| MAX.SMALLP) (|freplace| ( \\DISPLAYDATA DDCHARSETASCENT) |of| DISPLAYDATA |with| MAX.SMALLP))) (PUTPROPS \\DSPGETCHARWIDTH MACRO ((CHARCODE DD) (\\FGETWIDTH (|ffetch| (\\DISPLAYDATA DDWIDTHSCACHE) |of| DD) CHARCODE))) (PUTPROPS \\DSPGETCHARIMAGEWIDTH MACRO ((CHARCODE DD) (\\FGETIMAGEWIDTH (|ffetch| (\\DISPLAYDATA DDCHARIMAGEWIDTHS) |of| DD) CHARCODE))) (PUTPROPS \\DSPGETCHAROFFSET MACRO ((CHARCODE DD) (\\GETBASE (|ffetch| (\\DISPLAYDATA DDOFFSETSCACHE) |of| DD) CHARCODE))) (PUTPROPS \\CONVERTOP MACRO ((OP) (* |rrb| "14-NOV-80 11:14") (* |Only| |for| |alto| |bitblt| !!) ( SELECTQ OP (|replace| 0 |of| NIL |with| NIL) (PAINT 1) (INVERT 2) (ERASE 3) 0))) (PUTPROPS |\\SFInvert| MACRO ((|BitMap| \y) (* |corrects| |for| |the| |fact| |that| |alto| |bitmaps| |are| |stored| |with| 0\,0 |as| |upper| |left| |while| |lisp| |bitmaps| |have| 0\,0 |as| |lower| |left.| |The| |correction| |is| |actually| |off| |by| |one| (|greater|) |because| \a |majority| |of| |the| |places| |that| |it| |is| |called| |actually| |need| |one| |more| |than| |corrected| Y |value.|) (IDIFFERENCE (|fetch| (BITMAP BITMAPHEIGHT) |of| |BitMap|) \y))) (PUTPROPS |\\SFReplicate| MACRO (LAMBDA (|pattern|) (LOGOR |pattern| (LLSH |pattern| 8) (SETQ |pattern| (LLSH |pattern| 4)) (LLSH |pattern| 8)))) (PUTPROPS \\SETPBTFUNCTION MACRO (OPENLAMBDA (BBT |SourceType| |Operation|) (PROGN (|replace| ( PILOTBBT PBTOPERATION) |of| BBT |with| (SELECTQ |Operation| (ERASE 1) (PAINT 2) (INVERT 3) 0)) ( |replace| (PILOTBBT PBTSOURCETYPE) |of| BBT |with| (COND ((EQ (EQ |SourceType| (QUOTE INVERT)) (EQ |Operation| (QUOTE ERASE))) 0) (T 1)))))) (PUTPROPS \\BITBLT1 MACRO ((|bbt|) (|BitBltSUBR| |bbt|))) (PUTPROP (QUOTE BITBLT) (QUOTE MACRO) (QUOTE (= . BKBITBLT))) (PROGN (PUTPROPS \\INSURETOPWDS DMACRO (OPENLAMBDA (DS) (OR (EQ DS \\TOPWDS) (COND ((FMEMB ( DSPDESTINATION NIL DS) \\SCREENBITMAPS) (\\TOTOPWDS DS)))))) (PUTPROPS \\INSURETOPWDS MACRO ((DS) (* |For| |non-window| |implementations|) (PROGN)))) (PUTPROPS .WHILE.TOP.DS. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* FIRST |should| |be| \a |displaystream| |and| \a |variable.| |This| |macro| |may| |also| |take| \a |soft| |cursor| |down,| |similar| |to| |the| |way| .WHILE.CURSOR.DOWN. |does,| |but| |only| |if| |FIRST's| |destination| |is| |the| |same| |as| |the| |soft| |cursor's| |destination.| *) (COND (\\SOFTCURSORP ( SETQ SOFTCURSORUP (AND \\SOFTCURSORUPP (EQ (DSPDESTINATION NIL FIRST) \\CURSORDESTINATION))) (COND ( SOFTCURSORUP (SETQ DISPINTERRUPT (\\GETBASE \\EM.DISPINTERRUPT 0)) (\\PUTBASE \\EM.DISPINTERRUPT 0 0) (\\SOFTCURSORDOWN))))) (\\INSURETOPWDS FIRST) (PROGN . REST) (COND (SOFTCURSORUP ( \\SOFTCURSORUPCURRENT) (\\PUTBASE \\EM.DISPINTERRUPT 0 DISPINTERRUPT)))))) (PUTPROPS .WHILE.CURSOR.DOWN. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* |This| |macro| |should| |wrap| |around| |any| |code| |that| |draws| |or| |bitblts| |directly| |from| |or| |to| \a |screen| |bitmap.| E.\g. DRAWGRAYBOX |in| HLDISPLAY |which| |puts| |up| \a |shadow| |box| |during| GETREGION. |The| |purpose| |of| |this| |macro| |is| |that| \a |soft| (|e.g.| |color|) |cursor's| |bits| |not| |be| |taken| |to| |be| |screen| |bits| |while| FIRST & REST |are| |done.| *) ( COND (\\SOFTCURSORP (SETQ SOFTCURSORUP \\SOFTCURSORUPP) (COND (SOFTCURSORUP (SETQ DISPINTERRUPT ( \\GETBASE \\EM.DISPINTERRUPT 0)) (\\PUTBASE \\EM.DISPINTERRUPT 0 0) (\\SOFTCURSORDOWN))))) (PROGN FIRST . REST) (COND (SOFTCURSORUP (\\SOFTCURSORUPCURRENT) (\\PUTBASE \\EM.DISPINTERRUPT 0 DISPINTERRUPT)))))) (ADDTOVAR GLOBALVARS \\TOPWDS) (DEFOPTIMIZER TTYDISPLAYSTREAM (&REST X) (COND ((NULL (CAR X)) (QUOTE \\TERM.OFD)) (T (QUOTE IGNOREMACRO)))) (GLOBALVARS BELLCNT BELLRATE TTYBACKGROUNDFNS |\\DisplayStoppedForLogout| \\CARET.UP) (PUTPROPS \\CHECKCARET MACRO ((X) (AND \\CARET.UP (\\CARET.DOWN X)))) (PUTPROPS \\DSPTRANSFORMX MACRO ((X DD) (* |transforms| |an| \x |coordinate| |into| |the| |destination| |coordinate.|) (IPLUS X (|fetch| (\\DISPLAYDATA DDXOFFSET) |of| DD)))) (PUTPROPS \\DSPTRANSFORMY MACRO ((Y DD) (* |transforms| |an| \y |coordinate| |into| |the| |destination| |coordinate.|) (IPLUS Y (|fetch| (\\DISPLAYDATA DDYOFFSET) |of| DD)))) (PUTPROPS \\OFFSETBOTTOM MACRO ((X) (* |gives| |the| |destination| |coordinate| |address| |of| |the| |origin.|) (|fetch| (\\DISPLAYDATA DDYOFFSET) |of| X))) (PUTPROPS \\OFFSETLEFT MACRO ((DD) (* |returns| |the| \x |origin| |of| |display| |data| |destination| |coordinates.|) (|fetch| (\\DISPLAYDATA DDXOFFSET) |of| DD))) (PUTPROPS DISPLAYINITIALIZEDP MACRO (NIL (* |always| |initialized| |now|) T)) (PUTPROPS DISPLAYSTARTEDP MACRO (NIL |\\DisplayStarted|)) (GLOBALVARS |\\DisplayStarted| |\\DisplayStreamsInitialized| |\\DisplayInitialed| WHOLEDISPLAY WHOLESCREEN SCREENWIDTH SCREENHEIGHT) (PUTPROP (QUOTE LLDISPLAY) (QUOTE IMPORTDATE) (IDATE "18-Apr-1994 00:20:42")) (RECORD REGION (LEFT BOTTOM WIDTH HEIGHT) LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767 ( ACCESSFNS ((TOP (IPLUS (|fetch| (REGION BOTTOM) |of| DATUM) (|fetch| (REGION HEIGHT) |of| DATUM) -1)) (PTOP (IPLUS (|fetch| (REGION BOTTOM) |of| DATUM) (|fetch| (REGION HEIGHT) |of| DATUM))) (RIGHT (IPLUS (|fetch| (REGION LEFT) |of| DATUM) (|fetch| (REGION WIDTH) |of| DATUM) -1)) (PRIGHT (IPLUS (|fetch| ( REGION LEFT) |of| DATUM) (|fetch| (REGION WIDTH) |of| DATUM))))) (TYPE? (AND (EQLENGTH DATUM 4) (EVERY DATUM (FUNCTION NUMBERP)))) (SYSTEM)) (DATATYPE BITMAP ((BITMAPBASE POINTER) (BITMAPRASTERWIDTH WORD) (BITMAPHEIGHT WORD) (BITMAPWIDTH WORD) (BITMAPBITSPERPIXEL WORD)) BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((|BitMapHiLoc| WORD) ( |BitMapLoLoc| WORD)) (* \; "overlay initial pointer")) (SYSTEM)) (BLOCKRECORD BITMAPWORD ((BITS WORD)) (SYSTEM)) (RECORD POSITION (XCOORD . YCOORD) (TYPE? (AND (LISTP DATUM) (NUMBERP (CAR DATUM)) (NUMBERP (CDR DATUM )))) (SYSTEM)) (DATATYPE CURSOR (CUIMAGE CUMASK CUHOTSPOTX CUHOTSPOTY CUDATA) (ACCESSFNS ((CUBITSPERPIXEL (|fetch| ( BITMAP BITMAPBITSPERPIXEL) |of| (|fetch| (CURSOR CUIMAGE) |of| DATUM))))) (SYSTEM)) (RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME) (SYSTEM)) (RECORD SCREENREGION (SCREEN . REGION) (SUBRECORD REGION) (TYPE? (AND (LISTP DATUM) (|type?| SCREEN ( CAR DATUM)) (|type?| REGION (CDR DATUM)))) (SYSTEM)) (RECORD SCREENPOSITION (SCREEN . POSITION) (SUBRECORD POSITION) (TYPE? (AND (LISTP DATUM) (|type?| SCREEN (CAR DATUM)) (|type?| POSITION (CDR DATUM)))) (SYSTEM)) (PUTPROPS CURSORBITMAP MACRO (NIL |CursorBitMap|)) (RPAQQ HARDCURSORHEIGHT 16) (RPAQQ HARDCURSORWIDTH 16) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (ADDTOVAR GLOBALVARS |CursorBitMap|) (ARRAYRECORD POLYNOMIAL (A B C D) (CREATE (ARRAY 4 (QUOTE FLOATP))) (SYSTEM)) (RECORD SPLINE (\#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY)) (PUTPROPS HALF MACRO ((X) (LRSH X 1))) (PUTPROPS \\FILLCIRCLEBLT MACRO (OPENLAMBDA (CX CY X Y) (* \; "calls bitblt twice to fill in one line of the circle.") (\\LINEBLT FCBBT (IDIFFERENCE CX X) (IPLUS CY Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS ) (\\LINEBLT FCBBT (IDIFFERENCE CX X) (IDIFFERENCE CY Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS))) (PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (VARS . X)))))) (PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (E (MAPC (QUOTE X) (QUOTE PRINTCURSOR)))))))) (ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH |ScreenBitMap|) (RPAQQ BLACKSHADE 65535) (RPAQQ WHITESHADE 0) (CONSTANTS (BLACKSHADE 65535) (WHITESHADE 0)) (RPAQQ GRAYSHADE 43605) (ADDTOVAR GLOBALVARS GRAYSHADE) (RECORD HLS (HUE LIGHTNESS SATURATION)) (RECORD RGB (RED GREEN BLUE)) (PUTPROP (QUOTE ADISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Sep-1994 17:07:04")) (ADDTOVAR SYSSPECVARS \\INTERRUPTABLE) (PUTPROPS UNINTERRUPTABLY INFO EVAL) (PUTPROPS UNINTERRUPTABLY DMACRO ((X . Y) ((LAMBDA (\\INTERRUPTABLE) (PROGN X . Y)) NIL))) (ADDTOVAR PRETTYPRINTMACROS (UNINTERRUPTABLY LAMBDA (FORM) (PROG ((POS (IPLUS 4 (POSITION)))) (PRIN1 "(") (PRIN2 (CAR FORM)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM (CDR FORM)))) (TAB POS 0)) (PRINTDEF FORM POS T T FNSLST) (PRIN1 ")")))) (BLOCKRECORD INTERRUPTSTATE ((* |;;| "This is the structure used to communicate between the emulator and Lisp re interrupts. There is a bit per interrupt type, plus space for the character code that caused a keyboard interrupt." ) (* |;;| "This must match the INTSTAT definition in lispemul.h") (* |;;| "PENDING-INTERRUPT FLAGS:") (LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.") (ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.") (IOINTERRUPT FLAG) (GCDISABLED FLAG) (* \; "No mroe room in GC tables." ) (VMEMFULL FLAG) (* \; "VMEM is full!!") (STACKOVERFLOW FLAG) (* \; "Stack overflowed.") (STORAGEFULL FLAG) (* \; "Ran out of storage, atoms, etc.") (WAITINGINTERRUPT FLAG) (* |;;| "INTERRUPTS-IN-PROCESS MASK:") (P-LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.") ( P-ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.") (P-IOINTERRUPT FLAG) (P-GCDISABLED FLAG) ( * \; "No mroe room in GC tables.") (P-VMEMFULL FLAG) (* \; "VMEM is full!!") (P-STACKOVERFLOW FLAG) (* \; "Stack overflowed.") (P-STORAGEFULL FLAG) (* \; "Ran out of storage, atoms, etc.") ( P-WAITINGINTERRUPT FLAG) (INTCHARCODE WORD)) (BLOCKRECORD INTERRUPTSTATE ((* |;;| "Alternative view of the structure:") (PENDING BITS 8) (* \; "Pending-interrupt flags") (IN-PROGRESS BITS 8) (* \; "Mask to prevent re-interrupt for an interrupt in progress") (NIL WORD)))) (PUTPROPS \\TAKEINTERRUPT DMACRO ((PREFORM POSTFORM) (DECLARE (GLOBALVARS \\PENDINGINTERRUPT)) (COND ( (AND \\PENDINGINTERRUPT (INTERRUPTABLE~=NILUPTHESTACK)) PREFORM ((LAMBDA (\\INTERRUPTABLE) ( \\CALLINTERRUPTED)) T) POSTFORM)))) (PUTPROP (QUOTE AINTERRUPT) (QUOTE IMPORTDATE) (IDATE "17-Sep-1992 10:42:38")) (ACCESSFNS PUP ((PUPBASE (LOCF (|fetch| (ETHERPACKET EPBODY) |of| DATUM)))) (BLOCKRECORD PUPBASE (( PUPLENGTH WORD) (PUPTCONTROL BYTE) (PUPTYPE BYTE) (PUPID FIXP) (PUPDEST WORD) (PUPDESTSOCKET FIXP) ( PUPSOURCE WORD) (PUPSOURCESOCKET FIXP) (PUPDATASTART 266 WORD)) (BLOCKRECORD PUPBASE ((NIL WORD) ( TYPEWORD WORD) (PUPIDHI WORD) (PUPIDLO WORD) (PUPDESTNET BYTE) (PUPDESTHOST BYTE) (PUPDESTSOCKETHI WORD) (PUPDESTSOCKETLO WORD) (PUPSOURCENET BYTE) (PUPSOURCEHOST BYTE) (PUPSOURCESOCKETHI WORD) ( PUPSOURCESOCKETLO WORD)) (* \; "Temporary extra synonyms") (SYNONYM PUPDESTNET (DESTNET)) (SYNONYM PUPDESTHOST (DESTHOST)) (SYNONYM PUPDESTSOCKETHI (DESTSKTHI)) (SYNONYM PUPDESTSOCKETLO (DESTSKTLO)) ( SYNONYM PUPSOURCENET (SOURCENET)) (SYNONYM PUPSOURCEHOST (SOURCEHOST)) (SYNONYM PUPSOURCESOCKETHI ( SOURCESKTHI)) (SYNONYM PUPSOURCESOCKETLO (SOURCESKTLO))) (SYNONYM PUPDEST (DEST)) (SYNONYM PUPDESTSOCKET (DESTSKT)) (SYNONYM PUPSOURCE (SOURCE)) (SYNONYM PUPSOURCESOCKET (SOURCESKT)) (ACCESSFNS PUPDATASTART ((PUPCONTENTS (LOCF DATUM))))) (ACCESSFNS PUP ((PUPCHECKSUMBASE (|fetch| PUPBASE |of| DATUM)) (PUPCHECKSUMLOC (\\ADDBASE (|fetch| PUPBASE |of| DATUM) (FOLDLO (SUB1 (|fetch| PUPLENGTH |of| DATUM)) BYTESPERWORD)))) (BLOCKRECORD PUPCHECKSUMLOC ((PUPCHECKSUM WORD)))) (TYPE? (|type?| ETHERPACKET DATUM))) (ACCESSFNS PUPADDRESS ((PUPNET# (LRSH DATUM 8)) (PUPHOST# (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH PUPNET# 8) PUPHOST#))) (PUTPROPS \\LOCALPUPADDRESS MACRO (NIL \\LOCALPUPNETHOST)) (PUTPROPS \\LOCALPUPHOSTNUMBER MACRO (NIL (|fetch| PUPHOST# |of| \\LOCALPUPNETHOST))) (PUTPROPS \\LOCALPUPNETNUMBER MACRO (NIL (|fetch| PUPNET# |of| \\LOCALPUPNETHOST))) (ACCESSFNS ERRORPUP ((ERRORPUPBASE (|fetch| PUPCONTENTS |of| DATUM))) (BLOCKRECORD ERRORPUPBASE (( ERRORPUPCOPY 10 WORD) (* \; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* \; "Usually zero") (ERRORPUPSTRINGBASE WORD) (* \; "Human readable message")))) (RPAQQ PUPERRORCODES ((\\PUPE.CHECKSUM 1) (\\PUPE.NOSOCKET 2) (\\PUPE.SOCKETFULL 3) ( \\PUPE.GATEWAY.BADPUP 513) (\\PUPE.NOROUTE 514) (\\PUPE.NOHOST 515) (\\PUPE.LOOPED 516) ( \\PUPE.TOOLARGE 517) (\\PUPE.WRONG.GATEWAY 518) (\\PUPE.GATEWAYFULL 519))) (RPAQQ \\PUPE.CHECKSUM 1) (RPAQQ \\PUPE.NOSOCKET 2) (RPAQQ \\PUPE.SOCKETFULL 3) (RPAQQ \\PUPE.GATEWAY.BADPUP 513) (RPAQQ \\PUPE.NOROUTE 514) (RPAQQ \\PUPE.NOHOST 515) (RPAQQ \\PUPE.LOOPED 516) (RPAQQ \\PUPE.TOOLARGE 517) (RPAQQ \\PUPE.WRONG.GATEWAY 518) (RPAQQ \\PUPE.GATEWAYFULL 519) (CONSTANTS (\\PUPE.CHECKSUM 1) (\\PUPE.NOSOCKET 2) (\\PUPE.SOCKETFULL 3) (\\PUPE.GATEWAY.BADPUP 513) ( \\PUPE.NOROUTE 514) (\\PUPE.NOHOST 515) (\\PUPE.LOOPED 516) (\\PUPE.TOOLARGE 517) ( \\PUPE.WRONG.GATEWAY 518) (\\PUPE.GATEWAYFULL 519)) (PUTPROPS BINDPUPS MACRO (X (CONS (LIST (QUOTE LAMBDA) (CAR X) (CONS (QUOTE PROGN) (CDR X))) (|in| ( CAR X) |collect| (LIST (QUOTE ALLOCATE.PUP)))))) (PUTPROPS BINDPUPS INFO BINDS) (ADDTOVAR PRETTYPRINTMACROS (BINDPUPS LAMBDA (FORM) (PROG ((POS (IPLUS 2 (POSITION)))) (PRIN1 "(") ( PRIN2 (CAR FORM)) (SPACES 1) (PRINTDEF (CADR FORM) (POSITION)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM ( CDDR FORM)))) (TAB POS 0)) (PRINTDEF FORM POS T T FNSLST) (PRIN1 ")")))) (BLOCKRECORD PORT ((NETHOST WORD) (SOCKET FIXP)) (BLOCKRECORD PORT ((NET BYTE) (HOST BYTE) (SOCKETHI WORD) (SOCKETLO WORD)))) (ACCESSFNS ERRORPUP ((ERRORPUPBASE (|fetch| PUPCONTENTS |of| DATUM))) (BLOCKRECORD ERRORPUPBASE (( ERRORPUPCOPY 10 WORD) (* \; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* \; "Usually zero") (ERRORPUPSTRINGBASE WORD) (* \; "Human readable message")))) (GLOBALVARS \\ETHERWAIT1 \\ETHERTIMEOUT \\MAXETHERTRIES PUPTRACEFLG LOGINPASSWORDS) (GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS) (RPAQQ \\PUPOVLEN 22) (RPAQQ \\MAX.PUPLENGTH 532) (RPAQQ \\TIME.GETPUP 5) (CONSTANTS (\\PUPOVLEN 22) (\\MAX.PUPLENGTH 532) (\\TIME.GETPUP 5)) (PUTPROPS PUPPRINTMACROS VARTYPE ALIST) (PUTPROPS \\GETPUPWORD DMACRO ((PUP WORD#) (\\GETBASE (|fetch| PUPCONTENTS |of| PUP) WORD#))) (PUTPROPS \\PUTPUPWORD DMACRO ((PUP WORD# VALUE) (\\PUTBASE (|fetch| PUPCONTENTS |of| PUP) WORD# VALUE ))) (PUTPROPS \\GETPUPBYTE DMACRO ((PUP BYTE#) (\\GETBASEBYTE (|fetch| PUPCONTENTS |of| PUP) BYTE#))) (PUTPROPS \\PUTPUPBYTE DMACRO ((PUP BYTE# VALUE) (\\PUTBASEBYTE (|fetch| PUPCONTENTS |of| PUP) BYTE# VALUE))) (RPAQQ RAWPUPTYPES ((\\PT.ECHOME 1) (\\PT.IAMECHO 2) (\\PT.IAMBADECHO 3) (\\PT.ERROR 4) (\\PT.RFC 8) ( \\PT.ABORT 9) (\\PT.END 10) (\\PT.ENDREPLY 11) (\\PT.DATA 16) (\\PT.ADATA 17) (\\PT.ACK 18) (\\PT.MARK 19) (\\PT.INTERRUPT 20) (\\PT.INTERRUPTREPLY 21) (\\PT.AMARK 22) (\\PT.GATEWAYREQUEST 128) ( \\PT.GATEWAYRESPONSE 129) (\\PT.ALTOTIMEREQUEST 134) (\\PT.ALTOTIMERESPONSE 135) (\\PT.MSGCHECK 136) ( \\PT.NEWMAIL 137) (\\PT.NONEWMAIL 138) (\\PT.NOMAILBOX 139) (\\PT.LAURELCHECK 140) (\\PT.NAMELOOKUP 144) (\\PT.NAMERESPONSE 145) (\\PT.NAME/ADDRERROR 146) (\\PT.ADDRLOOKUP 147) (\\PT.ADDRRESPONSE 148) ( \\PT.PRINTERSTATUS 128) (\\PT.STATUSRESPONSE 129) (\\PT.PRINTERCAPABILITY 130) ( \\PT.CAPABILITYRESPONSE 131) (\\PT.PRINTJOBSTATUS 132) (\\PT.PRINTJOBRESPONSE 133))) (RPAQQ \\PT.ECHOME 1) (RPAQQ \\PT.IAMECHO 2) (RPAQQ \\PT.IAMBADECHO 3) (RPAQQ \\PT.ERROR 4) (RPAQQ \\PT.RFC 8) (RPAQQ \\PT.ABORT 9) (RPAQQ \\PT.END 10) (RPAQQ \\PT.ENDREPLY 11) (RPAQQ \\PT.DATA 16) (RPAQQ \\PT.ADATA 17) (RPAQQ \\PT.ACK 18) (RPAQQ \\PT.MARK 19) (RPAQQ \\PT.INTERRUPT 20) (RPAQQ \\PT.INTERRUPTREPLY 21) (RPAQQ \\PT.AMARK 22) (RPAQQ \\PT.GATEWAYREQUEST 128) (RPAQQ \\PT.GATEWAYRESPONSE 129) (RPAQQ \\PT.ALTOTIMEREQUEST 134) (RPAQQ \\PT.ALTOTIMERESPONSE 135) (RPAQQ \\PT.MSGCHECK 136) (RPAQQ \\PT.NEWMAIL 137) (RPAQQ \\PT.NONEWMAIL 138) (RPAQQ \\PT.NOMAILBOX 139) (RPAQQ \\PT.LAURELCHECK 140) (RPAQQ \\PT.NAMELOOKUP 144) (RPAQQ \\PT.NAMERESPONSE 145) (RPAQQ \\PT.NAME/ADDRERROR 146) (RPAQQ \\PT.ADDRLOOKUP 147) (RPAQQ \\PT.ADDRRESPONSE 148) (RPAQQ \\PT.PRINTERSTATUS 128) (RPAQQ \\PT.STATUSRESPONSE 129) (RPAQQ \\PT.PRINTERCAPABILITY 130) (RPAQQ \\PT.CAPABILITYRESPONSE 131) (RPAQQ \\PT.PRINTJOBSTATUS 132) (RPAQQ \\PT.PRINTJOBRESPONSE 133) (CONSTANTS (\\PT.ECHOME 1) (\\PT.IAMECHO 2) (\\PT.IAMBADECHO 3) (\\PT.ERROR 4) (\\PT.RFC 8) ( \\PT.ABORT 9) (\\PT.END 10) (\\PT.ENDREPLY 11) (\\PT.DATA 16) (\\PT.ADATA 17) (\\PT.ACK 18) (\\PT.MARK 19) (\\PT.INTERRUPT 20) (\\PT.INTERRUPTREPLY 21) (\\PT.AMARK 22) (\\PT.GATEWAYREQUEST 128) ( \\PT.GATEWAYRESPONSE 129) (\\PT.ALTOTIMEREQUEST 134) (\\PT.ALTOTIMERESPONSE 135) (\\PT.MSGCHECK 136) ( \\PT.NEWMAIL 137) (\\PT.NONEWMAIL 138) (\\PT.NOMAILBOX 139) (\\PT.LAURELCHECK 140) (\\PT.NAMELOOKUP 144) (\\PT.NAMERESPONSE 145) (\\PT.NAME/ADDRERROR 146) (\\PT.ADDRLOOKUP 147) (\\PT.ADDRRESPONSE 148) ( \\PT.PRINTERSTATUS 128) (\\PT.STATUSRESPONSE 129) (\\PT.PRINTERCAPABILITY 130) ( \\PT.CAPABILITYRESPONSE 131) (\\PT.PRINTJOBSTATUS 132) (\\PT.PRINTJOBRESPONSE 133)) (RPAQ? PUPTYPES RAWPUPTYPES) (RPAQQ WELLKNOWNPUPSOCKETS ((\\PUPSOCKET.TELNET 1) (\\PUPSOCKET.ROUTING 2) (\\PUPSOCKET.FTP 3) ( \\PUPSOCKET.MISCSERVICES 4) (\\PUPSOCKET.ECHO 5) (\\PUPSOCKET.EFTP 16) (\\PUPSOCKET.PRINTERSTATUS 17) (\\PUPSOCKET.LEAF 35))) (RPAQQ \\PUPSOCKET.TELNET 1) (RPAQQ \\PUPSOCKET.ROUTING 2) (RPAQQ \\PUPSOCKET.FTP 3) (RPAQQ \\PUPSOCKET.MISCSERVICES 4) (RPAQQ \\PUPSOCKET.ECHO 5) (RPAQQ \\PUPSOCKET.EFTP 16) (RPAQQ \\PUPSOCKET.PRINTERSTATUS 17) (RPAQQ \\PUPSOCKET.LEAF 35) (CONSTANTS (\\PUPSOCKET.TELNET 1) (\\PUPSOCKET.ROUTING 2) (\\PUPSOCKET.FTP 3) ( \\PUPSOCKET.MISCSERVICES 4) (\\PUPSOCKET.ECHO 5) (\\PUPSOCKET.EFTP 16) (\\PUPSOCKET.PRINTERSTATUS 17) (\\PUPSOCKET.LEAF 35)) (PUTPROP (QUOTE PUP) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 11:14:09")) (PUTPROPS UNLESSRDSYS MACRO ((NORMAL RDSYS) NORMAL)) (PUTPROPS UNLESSINEW MACRO ((NORMAL I-NEW) NORMAL)) (PUTPROPS 1ST MACRO ((A . B) A)) (PUTPROPS 2ND MACRO ((A B . C) B)) (PUTPROPS LOCAL MACRO ((X) X)) (PUTPROPS ALLOCAL MACRO ((X) X)) (PUTPROPS ADDBASE DMACRO (= . \\ADDBASE)) (PUTPROPS GETBASE DMACRO (= . \\GETBASE)) (PUTPROPS GETBASEBYTE DMACRO (= . \\GETBASEBYTE)) (PUTPROPS GETBASEPTR DMACRO (= . \\GETBASEPTR)) (PUTPROPS HILOC DMACRO (= . \\HILOC)) (PUTPROPS LOLOC DMACRO (= . \\LOLOC)) (PUTPROPS PUTBASE DMACRO (= . \\PUTBASE)) (PUTPROPS PUTBASEBYTE DMACRO (= . \\PUTBASEBYTE)) (PUTPROPS PUTBASEPTR DMACRO (= . \\PUTBASEPTR)) (PUTPROPS REPLACEPTRFIELD DMACRO (= . \\RPLPTR)) (PUTPROPS VAG2 DMACRO (= . \\VAG2)) (PUTPROPS PAGEBASE MACRO ((PTR) (|fetch| (POINTER PAGEBASE) |of| PTR))) (PUTPROPS PAGELOC MACRO (OPENLAMBDA (PTR) (IPLUS (LLSH (\\HILOC PTR) 8) (LRSH (\\LOLOC PTR) 8)))) (PUTPROP (QUOTE RENAMEMACROS) (QUOTE IMPORTDATE) (IDATE "27-Apr-1994 15:43:27")) (PUTPROPS MOUSESTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR ARGS) T)))) (PUTPROPS LASTMOUSESTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS) T))) (PUTPROPS UNTILMOUSESTATE MACRO (ARGS (COND ((AND (CDR ARGS) (CADR ARGS) (NEQ (CADR ARGS) T)) (* |time| |argument| |is| |given| |and| |is| |not| T |or| NIL\; |compile| |in| |time| |keeping| |loop.|) (LIST (QUOTE PROG) (LIST (LIST (QUOTE TIMEOUT) (LIST (QUOTE IPLUS) (QUOTE (CLOCK 0)) (LIST (QUOTE OR) (LIST (QUOTE NUMBERP) (CADR ARGS)) 100))) (QUOTE (NOWTIME (CLOCK 0)))) (QUOTE LP) (LIST (QUOTE COND) ( LIST (CONS (QUOTE MOUSESTATE) (LIST (CAR ARGS) T)) (QUOTE (RETURN T)))) (QUOTE (COND ((IGREATERP ( CLOCK0 NOWTIME) TIMEOUT) (RETURN NIL)) (T (\\BACKGROUND)))) (QUOTE (GO LP)))) (T (LIST (QUOTE PROG) NIL (QUOTE LP) (LIST (QUOTE COND) (LIST (CONS (QUOTE MOUSESTATE) (LIST (CAR ARGS) T)) (QUOTE (RETURN T )))) (QUOTE (\\BACKGROUND)) (QUOTE (GO LP))))))) (PUTPROPS KEYSETSTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR ARGS))))) (PUTPROPS LASTKEYSETSTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS)))) (PUTPROPS WITHIN MACRO ((A B C) (AND (IGEQ A B) (ILESSP A (IPLUS B C))))) (ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS) (PUTPROPS IABS MACRO (OPENLAMBDA (A) (COND ((IGEQ A 0) A) (T (IMINUS A))))) (PUTPROP (QUOTE HLDISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Mar-1994 10:48:02")) (PUTPROPS .COPYKEYDOWNP. MACRO (NIL (OR (KEYDOWNP (QUOTE LSHIFT)) (KEYDOWNP (QUOTE RSHIFT)) (KEYDOWNP (QUOTE COPY))))) (PUTPROPS WSOP MACRO (ARGS (LET ((METHOD (CADR (CAR ARGS))) (DISPLAY (CADR ARGS)) (OTHERARGS (CDDR ARGS))) (BQUOTE (SPREADAPPLY* (|fetch| (WSOPS (\\\, METHOD)) |of| (|fetch| (FDEV WINDOWOPS) |of| (\\\, DISPLAY))) (\\\, DISPLAY) (\\\,@ OTHERARGS)))))) (PUTPROPS \\COERCETODS MACRO (OPENLAMBDA (X) (COND ((|type?| WINDOW X) (|fetch| (WINDOW DSP) |of| X)) (T (\\ILLEGAL.ARG X))))) (PUTPROPS .WHILE.ON.TOP. MACRO ((FIRST . REST) (UNINTERRUPTABLY (\\INTERNALTOTOPW FIRST) . REST))) (PUTPROPS WINDOWOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS ))) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (|fetch| (SCREEN (\\\, (CADR OPNAME))) |of| (\\\, METHOD-DEVICE)) (\\\, METHOD-DEVICE) (\\\,@ TAIL)))) (T (ERROR "OPNAME not quoted: " OPNAME)))))) (RPAQQ |MinWindowWidth| 26) (RPAQQ |MinWindowHeight| 16) (CONSTANTS (|MinWindowWidth| 26) (|MinWindowHeight| 16)) (DATATYPE WINDOW (DSP (* \; "The display stream you use to actually printto the window.") NEXTW (* \; "Next window in the open-window list") SAVE (* \; "Saved image from anything this window's on top of") REG (* \; "Screen region this window occupies") BUTTONEVENTFN (* \; "FN called when left/middle mouse button goes up/down") RIGHTBUTTONFN (* \; "FN called when right mouse button goes up/down") CURSORINFN (* \; "Fn called when mouse enters window") CURSOROUTFN (* \; "Called when mouse leaves window") CURSORMOVEDFN (* \; "Called when mouse moves in window") REPAINTFN (* \; "Redisplay part of thie window") RESHAPEFN (* \; "Called when window is reshaped") EXTENT (* \; "Scrolling limits") USERDATA (* \; "Proplist to hold other window properites") VERTSCROLLREG (* \; "Region of vert scroll bar") HORIZSCROLLREG (* \; "Tegion of horiz scroll bar") SCROLLFN (* \; "Fn to scroll this window") VERTSCROLLWINDOW (* \; "Vert scroll bar") HORIZSCROLLWINDOW (* \; "Horiz scroll bar") CLOSEFN (* \; "Called at close time") MOVEFN (* \; "Called when window is moved") WTITLE (* \; "Window's title string, if any") NEWREGIONFN (* \; "Called to get new window shape") WBORDER (* \; "Window border-width, in pixels") PROCESS (* \; "Medley process associated with this window") WINDOWENTRYFN (* \; "Fn to call when kbd focus is switched here") SCREEN (* \; "Screen this window appears on") ( NATIVE-HANDLE FIXP) (* \; "Uniterpreted place for native window to store a C pointer to its private info") (NATIVE-INFO1 FIXP) ( * \; "Reserved in case the pointer must be 64 bits") (NATIVE-W1 WORD) (* \; "Word for use by native handler") (NATIVE-W2 WORD) (* \; "Word for use by native handler") (NATIVE-P1 POINTER) (* \; "Lisp pointer for use by native handler")) BUTTONEVENTFN _ (FUNCTION TOTOPW) WBORDER _ |WBorder| WINDOWENTRYFN _ (FUNCTION GIVE.TTY.PROCESS) (SYSTEM)) (DATATYPE SCREEN (SCONOFF SCDESTINATION SCWIDTH SCHEIGHT SCTOPW SCTOPWDS SCTITLEDS SCFDEV SCDS SCDATA (* |;;| "Space for native window manager interface to use.") (HANDLE FIXP) (* \; "Handle for emulator to store info about display for C code use.") (HANDLE2 FIXP) (* \; "Reserved in case HANDLE needs to be 64 bits on the C side.") (NATIVE-INFO POINTER) (* \; "POINTER for the private use of the emulator window code") NATIVETYPE (* \; "Symbol to tell what kind of native window system we're using.") (* |;;| "- - - Functional interface to screen management - - -") WINIMAGEOPS (* \; "IMAGEOPS to be used in display streas on this kind of screen") WINFDEV (* \; "FDEV for display streams on this screen") CREATEWFN (* \; "Create a window") OPENWFN (* \; "Open a window") CLOSEWFN (* \; "Close a window") MOVEWFN (* \; "Move a window") RELMOVEWFN (* \; "Move window, relative") SHRINKWFN (* \; "Shrink window to icon") EXPANDWFN (* \; "Expand icon to window") SHAPEWFN (* \; "Reshape a window") REDISPLAYFN (* \; "Redisplay (part of) a window") GETWINDOWPROPFN (* \; "Get window property value") PUTWINDOWPROPFN (* \; "Set window property value") BURYWFN (* \; "Move window behind all others") TOTOPWFN (* \; "Move iwindow in front of all others") IMPORTWFN (* \; "Take a native window and save its state internally") EXPORTWFN (* \; "Take a saved window state and open it on this screen, filling in screen and methods as needed.") DESTROYFN (* \; "Destroy this window, for GC finaliszation") SETCURSORFN (* \; "Set the cursor for this window.") PROMPTW (* \; "The prompt window for this screen") SHOWGCFN (* \; "Show GC indication; called with ON/OFF arg, t=>show gcing status, NIL=>turn off GC indicator.") DSPCREATEFN (* \; "Create a displaystream on this screen.") BBTTOWIN (* \; "BITBLT from a lisp bitmap to a window") BBTFROMWIN (* \; "BITBLT from a window to a lisp bitmap") BBTWINWIN (* \; "BITBLT from a window to another window.") SCCURSOR (* \; "CURSOR that's in effect for this screen by default.") SCKEYBOARD (* \; "Something about which keyboard we're receiving from.") SCDEPTH (* \; "# of bits per pixel on the screen. THIS WILL REPLACE SCBITSPERPIXEL ASAP.") SCCLOSEDOWN (* \; "Close down this screen cleanly, saving window state.") SCCLOSESCREEN (* \; "Close down thie screen cleanly, no state saving.") SCREOPEN (* \; "Reopen this screen?") SCCARETFLASH (* \; "Function to flash thecaret.") SCGETSCREENPOSITION (* \; "GETSCREENPOSITION") SCGETBOXSCREENPOSITION (* \; "GETBOXPOSITION") SCGETSCREENREGION (* \; "GETREGION") SCMOVEPOINTER (* \; "\\CURSORPOSITION")) SCONOFF _ (QUOTE OFF) (ACCESSFNS ((SCBITSPERPIXEL (COND ((|fetch| (SCREEN SCDESTINATION) |of| DATUM) (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| (|fetch| (SCREEN SCDESTINATION) |of| DATUM))) (T 1))) (SCREGION (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (|fetch| (SCREEN SCWIDTH) |of| DATUM) HEIGHT _ (|fetch| (SCREEN SCHEIGHT) |of| DATUM))))) (SYSTEM)) (GLOBALVARS WINDOWUSERFORMS ENDOFWINDOWUSERFORMS PROMPTWINDOW) (PUTPROP (QUOTE WINDOW) (QUOTE IMPORTDATE) (IDATE " 9-Apr-2000 17:36:29")) (PUTPROPS NNLITATOM MACRO (OPENLAMBDA (X) (AND X (LITATOM X)))) (PUTPROPS \\NULL.OR.FIXP MACRO (OPENLAMBDA (X) (OR (NULL X) (FIXP X)))) (PUTPROPS \\CHECKTYPE MACRO (X (PROG ((VAR (CAR X)) (PRED (CADR X))) (|if| (AND (LISTP PRED) (MEMB ( CAR PRED) (QUOTE (QUOTE FUNCTION)))) |then| (SETQ PRED (LIST (CADR PRED) VAR))) (RETURN (SUBPAIR ( QUOTE (MSG VAR PRED)) (LIST (CONCAT " is not a suitable value for the variable: " VAR) VAR PRED) (QUOTE (|until| PRED |do| (SETQ VAR ( ERROR VAR MSG))))))))) (PUTPROPS CANONICAL.TIMERUNITS MACRO (OPENLAMBDA (X) (* |Checks| |for| |common| |abbreviations| |before| |calling| |\\CanonicalizeTimerUnits|) (SELECTQ X ((TICKS MILLISECONDS SECONDS) (* |These| |are| |the| |canonical| |forms|) X) (NIL (QUOTE MILLISECONDS)) (|\\CanonicalizeTimerUnits| X)))) (PUTPROPS \\MACRO.EVAL DMACRO (Z (PROG ((X (EXPANDMACRO (CAR Z) T))) (|if| (EQ X (CAR Z)) |then| ( ERROR "No macro property -- \\MACRO.EVAL" X) |else| (RETURN (EVAL X)))))) (DEFOPTIMIZER \\MACRO.MX (FORM) FORM) (PUTPROP (QUOTE MACROAUX) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:26:31")) (RPAQQ MASK0WORD1\'S 32767) (RPAQQ MASK1WORD0\'S 32768) (RPAQQ MASKWORD1\'S 65535) (RPAQQ MASKHALFWORD1\'S 255) (RPAQQ BITSPERHALFWORD 8) (CONSTANTS MASK0WORD1\'S MASK1WORD0\'S MASKWORD1\'S MASKHALFWORD1\'S BITSPERHALFWORD) (PUTPROPS EQZEROP MACRO ((X) (EQ 0 X))) (PUTPROPS \\MOVETOBOX DMACRO (OPENLAMBDA (N D) (SELECTC (NTYPX N) (\\SMALLP (|replace| (FIXP HINUM) |of| D |with| 0) (|replace| (FIXP LONUM) |of| D |with| N)) (\\FIXP (|replace| (FIXP HINUM) |of| D |with| (|fetch| (FIXP HINUM) |of| N)) (|replace| (FIXP LONUM) |of| D |with| (|fetch| (FIXP LONUM) |of| N))) (\\ILLEGAL.ARG N)))) (PUTPROPS .XUNBOX. MACRO ((X HX LX) (|until| (SETQ LX (SELECTC (NTYPX X) (\\SMALLP (COND ((IGEQ X 0) ( SETQ HX 0) X) (T (SETQ HX MASKWORD1\'S) (\\LOLOC X)))) (\\FIXP (SETQ HX (|fetch| (FIXP HINUM) |of| X)) (|fetch| (FIXP LONUM) |of| X)) NIL)) |do| (SETQ X (LISPERROR "ILLEGAL ARG" X T))))) (PUTPROPS .XLLSH. MACRO ((HI LO N) (|if| (IGEQ N BITSPERWORD) |then| (* \; "Jump 16 bits in a single bound!") (SETQ HI LO) (SETQ LO 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) ( |if| (IGEQ N BITSPERHALFWORD) |then| (* \; "Jump 8 bits in a single bound!") (SETQ HI (LOGOR ( .LOHALFWORDHI. HI) (.HIHALFWORDLO. LO))) (SETQ LO (.LOHALFWORDHI. LO)) (SETQ N (IDIFFERENCE N BITSPERHALFWORD))) (|if| (IGEQ N 4) |then| (* \; "Jump 4 bits in a single bound!") (SETQ HI (LOGOR ( LRSH LO (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LLSH (LOGAND HI (CONSTANT (MASK.1\'S 0 (IDIFFERENCE BITSPERWORD 4)))) 4))) (SETQ LO (LLSH (LOGAND LO (CONSTANT (MASK.1\'S 0 (IDIFFERENCE BITSPERWORD 4)))) 4)) (SETQ N (IDIFFERENCE N 4))) (* \; "MASK0WORD1'S should be same as (SUB1 (LSH 1 (SUB1 BITSPERWORD)))") (FRPTQ N (SETQ HI (LLSH (LOGAND HI MASK0WORD1\'S) 1)) (SETQ LO (LLSH (|if| (IGEQ LO MASK1WORD0\'S) |then| (|add| HI 1) (LOGAND LO MASK0WORD1\'S) |else| LO) 1))))) (PUTPROPS .XLLSH1. MACRO ((HI LO) (SETQ HI (LLSH (LOGAND HI MASK0WORD1\'S) 1)) (SETQ LO (LSH (COND (( IGEQ LO MASK1WORD0\'S) (SETQ HI (LOGOR HI 1)) (LOGAND LO MASK0WORD1\'S)) (T LO)) 1)))) (PUTPROPS .XLRSH. MACRO ((HI LO N) (|if| (IGEQ N BITSPERWORD) |then| (* \; "Jump 10 bits in a single bound!") (SETQ LO HI) (SETQ HI 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) ( |if| (IGEQ N BITSPERHALFWORD) |then| (* \; "Jump 8 bits in a single bound!") (SETQ LO (LOGOR ( .HIHALFWORDLO. LO) (.LOHALFWORDHI. HI))) (SETQ HI (.HIHALFWORDLO. HI)) (SETQ N (IDIFFERENCE N BITSPERHALFWORD))) (|if| (IGEQ N 4) |then| (* \; "Jump 4 bits in a single bound!") (SETQ LO (LOGOR ( LLSH (LOGAND HI (CONSTANT (MASK.1\'S 0 4))) (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LRSH LO 4))) ( SETQ HI (LRSH HI 4)) (SETQ N (IDIFFERENCE N 4))) (* \; "MASK1WORD0'S should be same as \\SIGNBIT") ( FRPTQ N (SETQ LO (|if| (ODDP HI) |then| (LOGOR (LRSH LO 1) MASK1WORD0\'S) |else| (LRSH LO 1))) (SETQ HI (LRSH HI 1))))) (PUTPROPS .ADD.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* \; "Ignores carry out of high-order word") ( SETQ HX (.SUMSMALLMOD. HX HY)) (SETQ LX (.SUMSMALLMOD. LX LY (SETQ HX (|if| (EQ HX MAX.SMALL.INTEGER) |then| 0 |else| (ADD1 HX))))))) (PUTPROPS .SUB.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* \; "Ignores carry out of high-order word") ( SETQ HX (.DIFFERENCESMALLMOD. HX HY)) (SETQ LX (.DIFFERENCESMALLMOD. LX LY (SETQ HX (|if| (EQ HX 0) |then| MAX.SMALL.INTEGER |else| (SUB1 HX))))))) (PUTPROPS .32BITMUL. MACRO ((HR LR X Y) (PROG (HX LX HY LY) (|if| (ILESSP X Y) |then| (|swap| X Y)) (* \; "Y is the lesser of the two now") (.XUNBOX. X HX LX) (.XUNBOX. Y HY LY) LP (|if| (ODDP LY) |then| (.ADD.2WORD.INTEGERS. HR LR HX LX)) (|if| (EQ HY 0) |then| (SETQ LY (LRSH LY 1)) (|if| (EQ LY 0) |then| (RETURN)) |else| (.LRSH1. HY LY)) (* \; "Trim off highest bits, so that left-shifting doesn't generate FIXPs") (SETQ HX (LOGAND HX MASK0WORD1\'S)) (.LLSH1. HX LX) (GO LP)))) (PUTPROPS .SUMSMALLMOD. MACRO ((X Y OVERFLOWFORM) ((LAMBDA (|\\SumSmallModVar|) (DECLARE (LOCALVARS |\\SumSmallModVar|)) (IF (ILEQ X |\\SumSmallModVar|) THEN (IPLUS X Y) ELSE OVERFLOWFORM (IDIFFERENCE X (ADD1 |\\SumSmallModVar|)))) (IDIFFERENCE MAX.SMALL.INTEGER Y)))) (PUTPROPS .DIFFERENCESMALLMOD. MACRO ((X Y BORROWFORM) (IF (NOT (IGREATERP Y X)) THEN (IDIFFERENCE X Y ) ELSE BORROWFORM (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (IDIFFERENCE Y X)))))) (PUTPROPS \\GETBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (|\\Byte|) (DECLARE (LOCALVARS |\\Byte|)) (|if| (ODDP OFFST) |then| (LOGAND |\\Byte| (CONSTANT (MASK.1\'S 0 BITSPERNIBBLE))) |else| ( LRSH |\\Byte| BITSPERNIBBLE))) (\\GETBASEBYTE BASE (FOLDLO OFFST NIBBLESPERBYTE))))) (PUTPROPS \\PUTBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (|\\ByteNo|) (DECLARE ( LOCALVARS |\\ByteNo|)) ((LAMBDA (|\\Byte|) (DECLARE (LOCALVARS |\\Byte|)) (\\PUTBASEBYTE BASE |\\ByteNo| (|if| (ODDP OFFST) |then| (LOGOR (LOGAND |\\Byte| (CONSTANT (MASK.1\'S BITSPERNIBBLE BITSPERNIBBLE))) VAL) |else| (LOGOR (LOGAND |\\Byte| (CONSTANT (MASK.1\'S 0 BITSPERNIBBLE))) (LLSH VAL BITSPERNIBBLE))))) (\\GETBASEBYTE BASE |\\ByteNo|))) (FOLDLO OFFST NIBBLESPERBYTE)))) (PUTPROPS \\GETBASEBIT DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (|\\ByteNo| |\\BitMask|) (DECLARE ( LOCALVARS |\\ByteNo| |\\BitMask|)) (|if| (EQ 0 (LOGAND |\\BitMask| (\\GETBASEBYTE BASE |\\ByteNo|))) |then| 0 |else| 1)) (FOLDLO OFFST BITSPERBYTE) (MASK.1\'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) ( IMOD OFFST BITSPERBYTE)) 1)))) (PUTPROPS \\PUTBASEBIT DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (|\\ByteNo| |\\BitMask| |\\Byte|) (DECLARE (LOCALVARS |\\ByteNo| |\\BitMask| |\\Byte|)) (SETQ |\\Byte| (\\GETBASEBYTE BASE |\\ByteNo|)) (|if| (|if| (EQ 0 (LOGAND |\\BitMask| |\\Byte|)) |then| (NOT (EQ 0 VAL)) |else| (EQ 0 VAL)) |then| ( \\PUTBASEBYTE BASE |\\ByteNo| (LOGXOR |\\BitMask| |\\Byte|))) VAL) (FOLDLO OFFST BITSPERBYTE) ( MASK.1\'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) (IMOD OFFST BITSPERBYTE)) 1)))) (PUTPROP (QUOTE ADDARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 11:46:37")) (RPAQQ \\MAXFILEPAGE 65534) (CONSTANTS \\MAXFILEPAGE) (PUTPROP (QUOTE LLFAULT) (QUOTE IMPORTDATE) (IDATE "12-Feb-2021 16:52:07")) (PUTPROPS \\UPDATETIMERS MACRO (NIL (* * |Moves| |excess| |time| |from| |the| |processor| |clock| |to| |our| |software| |clocks.| |Needs| |to| |be| |run| |often,| |uninterruptably,| |preferably| |from| |the| |vertical| |retrace| |interrupt|) (* |Get| |processor| |clock|) (PROG ((EXCESS (\\BOXIDIFFERENCE (\\RCLK (LOCF (|fetch| RCLKTEMP0 |of| \\MISCSTATS))) (LOCF (|fetch| BASECLOCK |of| \\MISCSTATS))))) ( RETURN (COND ((OR (IGEQ EXCESS \\RCLKSECOND) (ILESSP EXCESS 0)) (* |More| |than| |one| |second| |has| |elapsed| |since| |we| |updated| |clocks|) (\\BOXIPLUS (LOCF (|fetch| BASECLOCK |of| \\MISCSTATS)) \\RCLKSECOND) (* |Increment| |base| |by| |one| |second|) (\\BOXIPLUS (LOCF (|fetch| MILLISECONDSCLOCK |of| \\MISCSTATS)) 1000) (* |Increment| |clocks| |by| 1 |second|) (\\BOXIPLUS (LOCF (|fetch| SECONDSCLOCK |of| \\MISCSTATS)) 1) T)))))) (RPAQQ \\RTCSECONDS 378) (RPAQQ \\RTCMILLISECONDS 380) (RPAQQ \\RTCBASE 382) (RPAQQ \\OFFSET.SECONDS 0) (RPAQQ \\OFFSET.MILLISECONDS 2) (RPAQQ \\OFFSET.BASE 4) (RPAQQ \\ALTO.RCLKSECOND 1680000) (RPAQQ \\ALTO.RCLKMILLISECOND 1680) (RPAQQ \\DLION.RCLKMILLISECOND 35) (RPAQQ \\DLION.RCLKSECOND 34746) (RPAQQ \\DOVE.RCLKMILLISECOND 63) (RPAQQ \\DOVE.RCLKSECOND 62500) (CONSTANTS (\\RTCSECONDS 378) (\\RTCMILLISECONDS 380) (\\RTCBASE 382) (\\OFFSET.SECONDS 0) ( \\OFFSET.MILLISECONDS 2) (\\OFFSET.BASE 4) (\\ALTO.RCLKSECOND 1680000) (\\ALTO.RCLKMILLISECOND 1680) ( \\DLION.RCLKMILLISECOND 35) (\\DLION.RCLKSECOND 34746) (\\DOVE.RCLKMILLISECOND 63) (\\DOVE.RCLKSECOND 62500)) (PUTPROPS ALTO.TO.LISP.DATE MACRO ((DATE) (LOGXOR DATE -2147483648))) (PUTPROPS LISP.TO.ALTO.DATE MACRO ((DATE) (LOGXOR DATE -2147483648))) (PUTPROP (QUOTE LLTIMER) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:13:11")) (DATATYPE SYSQUEUE ((NIL BYTE) (SYSQUEUEHEAD POINTER) (NIL BYTE) (SYSQUEUETAIL POINTER))) (BLOCKRECORD QABLEITEM ((NIL BITS 4) (QLINK POINTER) (* \; "Link to next thing in queue always in first pointer of datum, independent of what the datum is")) ( BLOCKRECORD QABLEITEM ((NIL BITS 4) (LINK POINTER) (* \; "Let's also be able to call it a LINK")))) (PUTPROPS \\QUEUEHEAD MACRO ((Q) (|fetch| (SYSQUEUE SYSQUEUEHEAD) |of| Q))) (PUTPROPS \\DETCONC MACRO (OPENLAMBDA (TQ) (PROG1 (\\PEEKTCONC TQ) (|if| (NULL (CAR (RPLACA TQ (CDAR TQ)))) |then| (RPLACD TQ))))) (PUTPROPS \\ENTCONC MACRO (= . TCONC)) (PUTPROPS \\PEEKTCONC MACRO (= . CAAR)) (DATATYPE ETHERPACKET ((NIL BYTE) (EPLINK POINTER) (* \; "For queue maintenence") (EPFLAGS BYTE) (* \; "optional flags for some applications") (EPUSERFIELD POINTER) (* \; "Arbitrary pointer for applications") (NIL BYTE) (EPPLIST POINTER) (* \; "Extra field for use as an A-list for properties") (EPTRANSMITTING FLAG) (* \; "True while packet is being transmitted and hence cannot be reused") (EPRECEIVING FLAG) (* \; "True when a packet has been seen at the head of the network's input queue at least once") (NIL BITS 6 ) (EPREQUEUE POINTER) (* \; "Where to requeue this packet after transmission") (NIL BYTE) (EPSOCKET POINTER) (NIL BYTE) (EPNETWORK POINTER) (EPTYPE WORD) (* \; "Type of packet to be encapsulated (PUP or XIP or 10TO3)") (NIL WORD) (EPTIMESTAMP FIXP) (* \; "Gets RCLK value when transmitted/received") (EPREQUEUEFN POINTER) (* \; "FN to perform requeueing") ( NIL 4 WORD) (* \; "Space for expansion") (* \; "Note: This next field wants to be quad+2 aligned so that the 10mb packet is quad+3 aligned") ( EPENCAPSULATION 8 WORD) (* \; "10mb encapsulation, or 3mb encapsulation with padding") (EPBODY 289 WORD) (* \; "Body of packet, header up to 16 words plus data up to 546 bytes"))) (ACCESSFNS ETHERAUX ((AUXPTR (CDR (ASSOC (QUOTE AUXPTR) (|fetch| EPPLIST |of| DATUM))) (\\EP.PUT.AUX DATUM (QUOTE AUXPTR) NEWVALUE)) (AUXWORD (OR (CDR (ASSOC (QUOTE AUXWORD) (|fetch| EPPLIST |of| DATUM)) ) 0) (\\EP.PUT.AUX DATUM (QUOTE AUXWORD) NEWVALUE)) (AUXBYTE (OR (CDR (ASSOC (QUOTE AUXBYTE) (|fetch| EPPLIST |of| DATUM))) 0) (\\EP.PUT.AUX DATUM (QUOTE AUXBYTE) NEWVALUE)))) (RPAQQ \\EPT.PUP 512) (RPAQQ \\EPT.XIP 1536) (RPAQQ \\3MBTYPE.XIP 1536) (RPAQQ \\10MBTYPE.XIP 1536) (RPAQQ \\EPT.10TO3 1537) (RPAQQ \\3MBTYPE.10TO3 1537) (RPAQQ \\EPT.UNKNOWN 255) (CONSTANTS \\EPT.PUP \\EPT.XIP \\3MBTYPE.XIP \\10MBTYPE.XIP \\EPT.10TO3 \\3MBTYPE.10TO3 \\EPT.UNKNOWN) (RPAQQ \\NULLCHECKSUM 65535) (CONSTANTS (\\NULLCHECKSUM 65535)) (DATATYPE NDB ((NETTYPE BYTE) (* \; "10 or 3 for now") (NDBNEXT POINTER) (* \; "Link to next NDB") ( NDBPUPNET# BYTE) (* \; "Pup number of this net. May be different from NS net number, though not in Xerox world") (NDBNSNET# POINTER) (* \; "Can be 32-bits, so might as well leave its box around") (NDBTASK# BYTE) (* \; "Task # of this network") (NDBBROADCASTP POINTER) (* \; "Function that returns true if packet is of broadcast type") (NDBPUPHOST# BYTE) (* \; "My pup address on this net. NS address is global to all nets, so not needed here") (NDBTRANSMITTER POINTER) (* \; "(NDB PACKET) -- fn to send a raw packet on this net. returns NIL on failure") (NIL BYTE) (NDBENCAPSULATOR POINTER) (* \; "(NDB PACKET HOST LENGTH TYPE) -- fn to encapsulate and send a higher-level packet on this net ") ( NDBCSB POINTER) (* \; "Pointer to CSB for this network") (NDBIQLENGTH BYTE) (NDBIQ POINTER) (* \; "Queue of empty packets for receiver") (NDBTQ POINTER) (* \; "Queue of packets to transmit") ( NDBTRANSLATIONS POINTER) (* \; "Cache of translations, 3:10 or 10:3 according to network") ( NDBETHERFLUSHER POINTER) (* \; "Turns off this ether. Args NDB") (NDBWATCHER POINTER) (NDBCANHEARSELF POINTER) (* \; "True if receiver can hear packets sent by transmitter") (NDBIPNET# POINTER) ( NDBIPHOST# POINTER) (NDBPUPTYPE WORD) (* \; "The packet encapsulation of PUP on this net") (NIL WORD) (NIL POINTER) (* \; "Spares"))) (RECORD ROUTING (RTNET# RTHOPCOUNT RTGATEWAY# RTNDB RTTIMER RTRECENT)) (PUTPROPS \\SERIALNUMBER MACRO (NIL (|fetch| (IFPAGE |SerialNumber|) |of| |\\InterfacePage|))) (PUTPROPS \\DEVICE.INPUT DOPVAL (1 MISC1 1)) (PUTPROPS \\DEVICE.OUTPUT DOPVAL (2 MISC2 2)) (PUTPROPS \\D0.STARTIO DOPVAL (1 MISC1 0)) (PUTPROP (QUOTE LLETHER) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 10:49:30")) (RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR) BRUSHSHAPE _ (QUOTE ROUND) BRUSHSIZE _ 1) (PUTPROPS IMAGEOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) ( QUOTE QUOTE)) (LIST (QUOTE |fetch|) (LIST (QUOTE IMAGEOPS) (CADAR ARGS)) (QUOTE |of|) (LIST (QUOTE |fetch|) (QUOTE (STREAM IMAGEOPS)) (QUOTE |of|) (CADR ARGS)))) (T (HELP "IMAGEOP - OPNAME not quoted:" ARGS))) (CDDR ARGS))))) (DATATYPE IMAGEOPS (IMAGETYPE IMCLOSEFN IMXPOSITION IMYPOSITION IMFONT IMLEFTMARGIN IMRIGHTMARGIN IMLINEFEED IMDRAWLINE IMDRAWCURVE IMDRAWCIRCLE IMDRAWELLIPSE IMFILLCIRCLE IMBLTSHADE IMBITBLT IMNEWPAGE IMMOVETO IMSCALE IMTERPRI IMTOPMARGIN IMBOTTOMMARGIN IMSPACEFACTOR IMFONTCREATE IMOPERATION IMCOLOR IMSTRINGWIDTH IMCHARWIDTH IMCHARWIDTHY IMBACKCOLOR IMBITMAPSIZE IMCLIPPINGREGION IMRESET IMDRAWPOLYGON IMFILLPOLYGON IMSCALEDBITBLT IMWRITEPIXEL IMCHARSET IMROTATE IMDRAWARC IMTRANSLATE IMSCALE2 IMPUSHSTATE IMPOPSTATE IMDEFAULTSTATE IMDRAWPOINT IMBLTCHAR IMXOFFSET IMYOFFSET) IMCLOSEFN _ (FUNCTION NILL) IMTERPRI _ (FUNCTION (LAMBDA (STREAM) (\\OUTCHAR STREAM (CHARCODE EOL)))) IMNEWPAGE _ (FUNCTION (LAMBDA (STREAM) (\\OUTCHAR STREAM (CHARCODE ^L)))) IMOPERATION _ (FUNCTION NILL) IMCOLOR _ (FUNCTION NILL) IMCLIPPINGREGION _ (FUNCTION NILL) IMRESET _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION NILL) IMSTRINGWIDTH _ (FUNCTION (LAMBDA (STREAM STR RDTBL) (STRINGWIDTH STR (DSPFONT NIL STREAM) RDTBL RDTBL))) IMCHARWIDTH _ (FUNCTION (LAMBDA (STREAM CHARCODE) (CHARWIDTH CHARCODE (DSPFONT NIL STREAM))) ) IMMOVETO _ (FUNCTION (LAMBDA (STREAM X Y) (IMAGEOP (QUOTE IMXPOSITION) STREAM STREAM X) (IMAGEOP ( QUOTE IMYPOSITION) STREAM STREAM Y))) IMBITMAPSIZE _ (FUNCTION (LAMBDA (STREAM BITMAP DIMENSION) ( SELECTQ DIMENSION (WIDTH (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP))) (HEIGHT (TIMES (DSPSCALE NIL STREAM) (BITMAPHEIGHT BITMAP))) (NIL (CONS (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP)) ( TIMES (DSPSCALE NIL STREAM) (BITMAPHEIGHT BITMAP)))) (\\ILLEGAL.ARG DIMENSION)))) IMWRITEPIXEL _ ( FUNCTION NILL) IMCHARSET _ (FUNCTION NILL) IMXPOSITION _ (FUNCTION NILL) IMYPOSITION _ (FUNCTION NILL) IMFONT _ (FUNCTION NILL) IMLEFTMARGIN _ (FUNCTION NILL) IMRIGHTMARGIN _ (FUNCTION NILL) IMLINEFEED _ (FUNCTION NILL) IMDRAWLINE _ (FUNCTION NILL) IMDRAWCURVE _ (FUNCTION NILL) IMDRAWCIRCLE _ (FUNCTION NILL) IMDRAWELLIPSE _ (FUNCTION NILL) IMFILLCIRCLE _ (FUNCTION NILL) IMBLTSHADE _ (FUNCTION NILL) IMBITBLT _ (FUNCTION NILL) IMSCALE _ (FUNCTION NILL) IMTOPMARGIN _ (FUNCTION NILL) IMBOTTOMMARGIN _ ( FUNCTION NILL) IMSPACEFACTOR _ (FUNCTION NILL) IMFONTCREATE _ (FUNCTION NILL) IMCHARWIDTHY _ (FUNCTION NILL) IMDRAWPOLYGON _ (FUNCTION \\DRAWPOLYGON.GENERIC) IMDRAWPOINT _ (FUNCTION \\DRAWPOINT.GENERIC) IMFILLPOLYGON _ (FUNCTION NILL) IMSCALEDBITBLT _ (FUNCTION NILL) IMROTATE _ (FUNCTION NILL) IMDRAWARC _ (FUNCTION NILL) IMTRANSLATE _ (FUNCTION NILL) IMPUSHSTATE _ (FUNCTION NILL) IMPOPSTATE _ (FUNCTION NILL) IMSCALE2 _ (FUNCTION NILL) IMDEFAULTSTATE _ (FUNCTION NILL) IMBLTCHAR _ (FUNCTION \\MEDW.BLTCHAR ) IMXOFFSET _ (FUNCTION \\MEDW.XOFFSET) IMYOFFSET _ (FUNCTION \\MEDW.YOFFSET)) (GLOBALVARS \\NOIMAGEOPS) (PUTPROP (QUOTE IMAGEIO) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:33:59")) (DATATYPE PROCESS ((PROCFX0 WORD) (* \; "= \\STACKHI to make this look like a STACKP") (PROCFX WORD) ( * \; "Stack pointer to this context when it is asleep") (PROCSTATUS BYTE) (* \; "Running or waiting") (PROCNAME POINTER) (* \; "Name for convenience in type-in reference") (PROCPRIORITY BYTE) (* \; "Priority level, 0-4. Not currently used.") (PROCQUEUE POINTER) (* \; "Queue of processes at the same priority") (NIL BYTE) (NEXTPROCHANDLE POINTER) (* \; "Pointer to next one") (PROCTIMERSET FLAG) (* \; "True if PROCWAKEUPTIMER has an interesting value") ( PROCBEINGDELETED FLAG) (* \; "True if proc was deleted, but hasn't been removed from \\PROCESSES yet") (PROCDELETED FLAG) (PROCSYSTEMP FLAG) (PROCNEVERSTARTED FLAG) (NIL FLAG) (NIL FLAG) (NIL FLAG) ( PROCWAKEUPTIMER POINTER) (* \; "a largep recording the time this proc last went to sleep") ( PROCTIMERLINK POINTER) (* \; "For linking proc in timer queue") (PROCTIMERBOX POINTER) (* \; "Scratch box to use for PROCWAKEUPTIMER when user does not give one explicitly") (WAKEREASON POINTER) (* \; "Reason process is being run. From WAKE.PROCESS or timer or event wakeup; T from simple BLOCK" ) (PROCEVENTORLOCK POINTER) (* \; "EVENT or MONITOR lock that this proc is waiting for") (PROCFORM POINTER) (* \; "Form to EVAL to start it going") (RESTARTABLE POINTER) (* \; "T = autorestart on error, HARDRESET = restart only on hard reset, NIL = never restart") (PROCWINDOW POINTER) (* \; "Window this process lives in, if any") (PROCFINISHED POINTER) (* \; "True if proc finished. Value is indication of how: NORMAL, DELETED, ERROR") (PROCRESULT POINTER) (* \; "Value it returned if it finished normally") (PROCFINISHEVENT POINTER) (* \; "Optional EVENT to be notified when proc finishes") (PROCMAILBOX POINTER) (* \; "Message queue") ( PROCDRIBBLEOUTPUT POINTER) (* \; "Binding for *DRIBBLE-OUTPUT* in this process") (PROCINFOHOOK POINTER ) (* \; "Optional user fn that displays info about process") (PROCTYPEAHEAD POINTER) (* \; "Buffer of typeahead destined for this proc") (PROCREMOTEINFO POINTER) (* \; "For Enterprise") ( PROCUSERDATA POINTER) (* \; "For PROCESSPROP") (PROCEVENTLINK POINTER) (* \; "Used to maintain EVENT queues") (PROCAFTEREXIT POINTER) (* \; "What to do with this process when coming back from a LOGOUT, etc") (PROCBEFOREEXIT POINTER) (* \; "If DON'T, can't logout") (PROCOWNEDLOCKS POINTER) (* \; "Pointer to first lock I currently own") ( PROCEVAPPLYRESULT POINTER) (* \; "For PROCESS.EVAL and PROCESS.APPLY when WAITFORRESULT is true") ( PROCTTYENTRYFN POINTER) (* \; "Is applied to a process when it becomes the tty process") ( PROCTTYEXITFN POINTER) (* \; "Is applied to a process when it ceases to be the tty process") ( PROCHARDRESETINFO POINTER) (* \; "HARDRESET stores info about unwind-protect cleanups here") ( PROCRESTARTFORM POINTER) (* \; "use this instead of PROCFORM when restarting") (PROCOLDTTYPROC POINTER ) (* \; "Process that had the tty when we got it") (NIL POINTER) (* \; "For expansion")) PROCTIMERBOX _ (CREATECELL \\FIXP) PROCFX0 _ \\STACKHI) (PUTPROPS THIS.PROCESS MACRO (NIL \\RUNNING.PROCESS)) (PUTPROPS TTY.PROCESS MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE \\TTY.PROCESS))))) (PUTPROPS TTY.PROCESSP MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE (OR (NULL (THIS.PROCESS) ) (EQ (THIS.PROCESS) (TTY.PROCESS)))))))) (GLOBALVARS \\RUNNING.PROCESS \\TTY.PROCESS \\PROC.RESTARTME \\PROC.RESETME \\PROC.ABORTME) (PUTPROP (QUOTE PROC) (QUOTE IMPORTDATE) (IDATE "17-Jun-1999 21:58:52")) (PUTPROPS \\BACKCHAR MACRO (OPENLAMBDA (STREAM) (* \; "Backs up over an NS character") (\\BACKNSCHAR STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)))) (PUTPROPS \\BACKNSCHAR MACRO ((ST SHIFTEDCHARSET COUNTERVAR) (COND ((\\XCCSP ST) (\\BACKXCCSCHAR ST SHIFTEDCHARSET COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR ( CL:FUNCALL (|ffetch| (STREAM BACKCHARFN) |of| ST) ST T)))) (T (CL:FUNCALL (|ffetch| (STREAM BACKCHARFN ) |of| ST) ST NIL))))))) (PUTPROPS \\CHECKEOLC MACRO (OPENLAMBDA (CH EOLC STREAM PEEKBINFLG COUNTERVAR) (* |;;| "Subtracts number of bytes read from COUNTERVAR, which may be NIL. In fact, should be NIL if PEEKBINFLG is T." ) (SELCHARQ CH (CR (SELECTC EOLC (CR.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND (PEEKBINFLG (* |;;| "T from PEEKC, compile-time constant. In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts" ) (COND ((EQ (CHARCODE LF) (UNINTERRUPTABLY (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* |;;| "Read the NS CR. We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \\NSPEEK that got the CR character. Since we are going to NS back the CR character, we don't need to update the counter variable" ) (PROG1 (\\PEEKBIN STREAM T) (* |;;| "LF must be in next BYTE after NS CR, regardless of coding. Character-set shifting bytes can't intervene. Then we back up over the CR that was \\NSINed above." ) (\\BACKNSCHAR STREAM)))) (CHARCODE EOL)) (T (CHARCODE CR)))) ((EQ (CHARCODE LF) (\\PEEKBIN STREAM T) ) (\\BIN STREAM) (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (SUB1 COUNTERVAR))) (CHARCODE EOL)) (T ( CHARCODE CR)))) (CHARCODE CR))) (LF (COND ((EQ EOLC LF.EOLC) (CHARCODE EOL)) (T (CHARCODE LF)))) CH))) (PUTPROPS \\INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* \; "returns a 16 bit character code") ( \\CHECKEOLC (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (FFETCH EOLCONVENTION OF STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \\INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* \; "returns a 16 bit character code") ( \\CHECKEOLC (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (|ffetch| EOLCONVENTION |of| STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \\PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR) (\\CHECKEOLC (\\NSPEEK STREAM (UNFOLD ( ACCESS-CHARSET STREAM) 256) NIL NOERROR) (|ffetch| EOLCONVENTION |of| STREAM) STREAM T))) (PUTPROPS \\NSIN MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* |;;;| "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here." ) (COND ((\\XCCSP ST) (\\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR ) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (|ffetch| (STREAM INCCODEFN) |of| ST) ST T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (|ffetch| (STREAM INCCODEFN) |of| ST) ST NIL))))))) (PUTPROPS \\NSPEEK MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* |;;;| "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here." ) (COND ((\\XCCSP ST) (\\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST) 256) NIL NOERROR)) (T (COND ((QUOTE COUNTERVAR) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (|ffetch| (STREAM PEEKCCODEFN) |of| ST) ST NOERROR T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (|ffetch| ( STREAM PEEKCCODEFN) |of| ST) ST NOERROR NIL))))))) (PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET)) (PUTPROPS \\CONV.JIS.TO.XCCS MACRO (OPENLAMBDA (KU TEN) (* |;;;| "Some character code is not equivalent between JIS and XCCS. In such case, we have to convert the character to corresponding XCCS." ) (COND ((\\NOT.EQUIVALENT.TO.XCCS KU) (\\DO.CONV.JIS.TO.XCCS KU TEN)) (T (LOGOR (UNFOLD KU 256) TEN)) ))) (PUTPROPS \\DO.CONV.JIS.TO.XCCS MACRO ((KU TEN) (* |;;;| " Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.") (COND ((\\INVALID.TENP TEN) *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (SELECTQ KU ((33 34 38) (* \; "1, 2 and 6 KU") (LET* ((CONVTABLE (\\EXTARACT.CONV.TABLE KU)) (SET (\\EXTRACT.SET TEN CONVTABLE)) ( CODE (\\EXTRACT.CODE TEN CONVTABLE))) (COND ((NEQ SET 255) (LOGOR (UNFOLD SET 256) CODE)) (T (COND (( EQ CODE 255) (* \; "Not defined in JIS.") *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (* \; "Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.") (COND ( *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 256) TEN)))))))))) (35 (* \; "3 KU") (* \; "Alpha numeric codes are all defined as single byte codes in XCCS.") TEN) (40 (* \; "8 KU") (COND ((< 0 TEN 33) (COND (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\\EXTRACT.NO.FONT.CODE ( LOGOR KU TEN))))) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (116 (* \; "84 KU") (COND ((< 0 TEN 5) (LOGOR 29952 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (117 (* \; "85 KU") (COND ((< 0 TEN 28) (LOGOR 29696 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) *DEFAULT-NOT-CONVERTED-FAT-CODE*))))) (PUTPROPS \\CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC) (* |;;;| "Returns JIS code corresponding to XCCS charcode. Handle HANKAKU as well as ZENKAKU. If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so. Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode." ) (OR (COND ((\\ASCIIP CC) CC) ((\\NOT.EQUIVALENT.TO.JIS CC) (\\DO.CONV.XCCS.TO.JIS CC)) (( \\CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM) (* \; "ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.") (\\CONV.ZENKAKU.KANA CC)) ( T CC)) CC))) (PUTPROPS \\DO.CONV.XCCS.TO.JIS MACRO ((CC) (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*))) (PUTPROPS \\ASCIIP MACRO (OPENLAMBDA (CC) (AND (EQ (FOLDLO CC 256) 0) (< (LOGAND CC 255) 128)))) (PUTPROPS \\NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC) (OR (EQ (FOLDLO CC 256) 0) (EQ (FOLDLO CC 256 ) 33) (EQ (FOLDLO CC 256) 34) (EQ (FOLDLO CC 256) 38) (EQ (FOLDLO CC 256) 40) (EQ (FOLDLO CC 256) 239) (EQ (FOLDLO CC 256) 241)))) (PUTPROPS \\CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM) (STREAMPROP OUTSTREAM :HTOZP))) (PUTPROPS \\CONV.ZENKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*))) (PUTPROPS \\XCCSIN MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* |;;;| "returns a 16 bit character code. SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes. COUNTERVAR if non-NIL is decremented by number of bytes read. Doesn't do EOL conversion -- \\INCHAR and \\INCCODE do that." ) (LET ((CHAR (\\BIN STREAM)) SCSET) (COND ((EQ CHAR NSCHARSETSHIFT) (* \; "Shifting character sets") (ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\\BIN STREAM))) (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* \; "2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3))) (EQ 0 (\\BIN STREAM))) \\NORUNCODE) (T (\\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ CHAR (\\BIN STREAM)) (SETQ SCSET (COND ((QUOTE SHIFTEDCSETVAR) (* \; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256))))) (T (SETQ SCSET SHIFTEDCSET))) ( COND ((EQ SCSET (UNFOLD \\NORUNCODE 256)) (* \; "just read two bytes and combine them to a 16 bit value") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR ( IDIFFERENCE COUNTERVAR 2))) (LOGOR (UNFOLD CHAR 256) (\\BIN STREAM))) (CHAR (AND (QUOTE COUNTERVAR) ( SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 1))) (AND CHAR (LOGOR SCSET CHAR))))))) (PUTPROPS \\XCCSPEEK MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* |;;| "Returns a 16 bit character code. Doesn't do EOL conversion--\\INCHAR does that. May actually read the character-set shift, storing the result in the stream. COUNTERVAR, if given, is updated to reflect any such bytes that are actually read" ) (PROG ((CHAR (\\PEEKBIN STREAM NOERROR)) SCSET) (COND ((NULL CHAR) (RETURN NIL)) ((EQ CHAR NSCHARSETSHIFT) (* \; "CHARSETVAR=NIL means don't set") (\\BIN STREAM) (* \; "Consume the char shift byte") (ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\\BIN STREAM))) (* \; "Note: no eof error check on this \\BIN -- an eof in the middle of a charset shift is an error") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* \; "2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3))) (EQ 0 (\\BIN STREAM))) \\NORUNCODE) (T (\\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ SCSET (COND ((QUOTE SHIFTEDCSETVAR) (* \; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR ( UNFOLD SCSET 256))) (T (UNFOLD SCSET 256)))) (COND ((NULL (SETQ CHAR (\\PEEKBIN STREAM NOERROR))) ( RETURN NIL)))) (T (SETQ SCSET SHIFTEDCSET))) (RETURN (COND ((EQ SCSET (UNFOLD \\NORUNCODE 256)) (* |;;| "just peek two bytes and combine them to a 16 bit value. Again, is an error if we hit eof in mid-character" ) (\\BIN STREAM) (PROG1 (LOGOR (UNFOLD CHAR 256) (\\PEEKBIN STREAM NOERROR)) (\\BACKFILEPTR STREAM))) (T (LOGOR SHIFTEDCSET CHAR))))))) (PUTPROPS \\BACKXCCSCHAR MACRO ((STREAM SHIFTEDCHARSET COUNTERVAR) (AND (\\BACKFILEPTR STREAM) (COND ( (COND (SHIFTEDCHARSET (EQ SHIFTEDCHARSET (UNFOLD \\NORUNCODE 256))) (T (EQ \\NORUNCODE (ACCESS-CHARSET STREAM)))) (COND ((\\BACKFILEPTR STREAM) (AND (QUOTE COUNTERVAR) (|add| COUNTERVAR 2)) T) ((QUOTE COUNTERVAR) (|add| COUNTERVAR 1)))) ((QUOTE COUNTERVAR) (|add| COUNTERVAR 1)))))) (PUTPROPS \\XCCSP MACRO (OPENLAMBDA (ST) (NOT (|ffetch| (STREAM NOTXCCS) |of| (\\DTEST ST (QUOTE STREAM)))))) (PUTPROPS \\EXTRACT.NO.FONT.CODE MACRO ((JISCODE) (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE* )))) (PUTPROPS \\EXTARACT.CONV.TABLE MACRO ((KU) (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*)))) (PUTPROPS \\NOT.EQUIVALENT.TO.XCCS MACRO ((KU) (* |;;;| " The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU. Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here." ) (OR (EQ KU 33) (EQ KU 34) (EQ KU 35) (EQ KU 38) (EQ KU 40) (EQ KU 116) (EQ KU 117)))) (PUTPROPS \\EXTRACT.SET MACRO ((TEN TABLE) (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32) 2) 1)) )) (PUTPROPS \\EXTRACT.CODE MACRO ((TEN TABLE) (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32) 2)))) (PUTPROPS \\CHNAGE.KI.MODE MACRO (OPENLAMBDA (ST INPUTFLG ENTERP) (* |;;;| "INPUTFLG is true if \\CHNAGE.KI.MODE is called in the context in which ST is an input stream.") (COND (INPUTFLG (COND (ENTERP (|freplace| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| T)) ( T (|freplace| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| NIL)))) (T (COND (ENTERP ( |freplace| (STREAM OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| T)) (T (|freplace| (STREAM OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| NIL))))))) (PUTPROPS \\KIMODEP MACRO (OPENLAMBDA (ST INPUTFLG) (* |;;;| "INPUTFLG is true if \\KIMODEP is called in the context in which ST is an input stream.") (COND ( INPUTFLG (|ffetch| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)))) (T (|ffetch| (STREAM OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM))))))) (PUTPROPS \\HANKAKUP MACRO ((CHAR) (< 160 CHAR 224))) (PUTPROPS \\KANJIP MACRO ((CHAR) (< 12158 CHAR 29733))) (PUTPROPS \\NOTGAIJIP MACRO ((CHAR) (OR (< 8480 CHAR 10305) (< 12158 CHAR 29733)))) (PUTPROPS \\INVALID.TENP MACRO (OPENLAMBDA (TEN) (OR (< TEN 33) (< 126 TEN)))) (PUTPROPS \\CONV.HANKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*))) (PUTPROPS \\OUTKI MACRO ((STREAM) (\\BOUT OUTSTREAM (CHARCODE ESC)) (\\BOUT OUTSTREAM (CHARCODE $)) ( \\BOUT OUTSTREAM (CHARCODE B)))) (PUTPROPS \\OUTKO MACRO ((STREAM) (\\BOUT OUTSTREAM (CHARCODE ESC)) (\\BOUT OUTSTREAM (CHARCODE \()) ( \\BOUT OUTSTREAM (CHARCODE J)))) (PUTPROPS \\CONV.SJIS.TO.JIS MACRO (OPENLAMBDA (HI LO) (* |;;;| "Convert Shift-JIS to JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively." ) (SETQ CH1 (IDIFFERENCE HI (COND ((> HI 159) 177) (T 113)))) (SETQ CH1 (IPLUS (UNFOLD CH1 2) 1)) ( SETQ CH2 (COND ((> LO 158) (PROG1 (IDIFFERENCE LO 126) (SETQ CH1 (IPLUS CH1 1)))) (T (IDIFFERENCE LO ( COND ((> LO 126) (IPLUS 31 1)) (T 31)))))))) (PUTPROPS \\CONV.JIS.TO.SJIS MACRO (OPENLAMBDA (HI LO) (* |;;;| "Convert JIS to Shift-JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively." ) (SETQ CH2 (COND ((ODDP HI) (SETQ CH2 (IPLUS LO 31)) (COND ((>= CH2 127) (IPLUS CH2 1)) (T CH2))) (T (IPLUS LO 126)))) (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33) 2) 129)) (AND (> CH1 159) (SETQ CH1 ( IPLUS CH1 64))))) (PUTPROPS \\SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR) (OR (< 127 CHAR 160) (< 223 CHAR 256)))) (PUTPROPS \\EUC.KANJI.FIRST.BYTEP MACRO ((CHAR) (< 160 CHAR 255))) (PUTPROPS \\GAIJIP MACRO ((CHAR) (EQ CHAR 143))) (PUTPROPS \\EUC.HANKAKUP MACRO ((CHAR) (EQ CHAR 142))) (PUTPROP (QUOTE LLREAD) (QUOTE IMPORTDATE) (IDATE " 4-Feb-2021 17:06:41")) (PUTPROPS EMPASSWORDLOC DMACRO (LAMBDA NIL (* |lmm| "24-MAR-83 06:46") (|fetch| (IFPAGE |UserPswdAddr| ) |of| |\\InterfacePage|))) (PUTPROPS \\DECRYPT.PWD.CHAR MACRO ((CHAR) (LOGXOR CHAR 73))) (PUTPROP (QUOTE PASSWORDS) (QUOTE IMPORTDATE) (IDATE "16-May-1990 21:02:21")) (RPAQQ MICASPERINCH 2540) (RPAQQ MICASPERMILLIMETER 100) (CONSTANTS (MICASPERINCH 2540) (MICASPERMILLIMETER 100)) (PUTPROP (QUOTE INTERPRESS) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 21:56:38")) (RPAQ MICASPERPT (FQUOTIENT 2540 72)) (RPAQQ IHALFMICASPERPT 17) (RPAQQ IMICASPERPT 35) (CONSTANTS (MICASPERPT (FQUOTIENT 2540 72)) (IHALFMICASPERPT 17) (IMICASPERPT 35)) (DEFMACRO \\MICASTOPTS (MICAS) (COND ((NUMBERP MICAS) (QUOTIENT MICAS MICASPERPT)) (T (BQUOTE ( QUOTIENT (\\\, MICAS) MICASPERPT))))) (PUTPROP (QUOTE HARDCOPY) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 22:15:08")) (FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT) (PUTPROP (QUOTE CMLARRAY) (QUOTE IMPORTDATE) (IDATE " 6-Jan-1993 12:21:21")) (RPAQQ \\MISCN-TABLE-LIST ((USER-SUBR 0 \\USER-SUBR-UFN T) (CL:VALUES 1 CL::VALUES-UFN NIL) (CL:SXHASH 2 CL::SXHASH-UFN NIL) (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL) (STRINGHASHBITS 4 \\STRINGHASHBITS-UFN NIL) (STRING-EQUAL-HASHBITS 5 \\STRING-EQUAL-HASHBITS-UFN NIL) (CL:VALUES-LIST 6 CL::VALUES-LIST-UFN NIL) (|LCFetchMethod| 7 |LCFetchMethod| NIL) (|LCFetchMethodOrHelp| 8 NIL NIL) ( |LCFindVarIndex| 9 NIL NIL) (|LCGetIVValue| 10 NIL NIL) (|LCPutIVValue| 11 NIL NIL))) (RPAQQ \\USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN) (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN))) (RPAQQ \\INITSUBRS ((BACKGROUNDSUBR 6) (CHECKBCPLPASSWORD 7) (DISKPARTITION 8) (DSPBOUT 9) (DSPRATE 10 ) (GATHERSTATS 11) (GETPACKETBUFFER 12) (LISPFINISH 13) (MOREVMEMFILE 14) (RAID 15) (READRAWPBI 16) ( WRITERAWPBI 17) (SETSCREENCOLOR 18) (SHOWDISPLAY 19) (PUPLEVEL1STATE 20) (WRITESTATS 21) ( CONTEXTSWITCH 22) (COPYSYS0SUBR 23) (WRITEMAP 24) (UFS-GETFILENAME 34) (UFS-DELETEFILE 35) ( UFS-RENAMEFILE 36) (COM-READPAGES 37) (COM-WRITEPAGES 38) (COM-TRUNCATEFILE 39) (UFS-DIRECTORYNAMEP 41 ) (COM-GETFREEBLOCK 45) (SETUNIXTIME 48) (GETUNIXTIME 49) (COPYTIMESTATS 50) (UNIX-USERNAME 51) ( UNIX-FULLNAME 52) (UNIX-GETENV 53) (UNIX-GETPARM 54) (CHECK-SUM 55) (ETHER-SUSPEND 56) (ETHER-RESUME 57) (ETHER-AVAILABLE 58) (ETHER-RESET 59) (ETHER-GET 60) (ETHER-SEND 61) (ETHER-SETFILTER 62) ( ETHER-CHECK 63) (DSPCURSOR 64) (SETMOUSEXY 65) (DSP-VIDEOCOLOR 66) (DSP-SCREENWIDTH 67) ( DSP-SCREENHEIGHT 68) (BITBLTSUB 69) (BLTCHAR 70) (TEDIT.BLTCHAR 71) (BITBLT.BITMAP 72) ( BLTSHADE.BITMAP 73) (RS232C-CMD 74) (RS232C-READ-INIT 75) (RS232C-WRITE 76) (KEYBOARDBEEP 80) ( KEYBOARDMAP 81) (KEYBOARDSTATE 82) (VMEMSAVE 89) (LISP-FINISH 90) (NEWPAGE 91) (DORECLAIM 92) ( DUMMY-135Q 93) (NATIVE-MEMORY-REFERENCE 94) (OLD-COMPILE-LOAD-NATIVE 95) (DISABLEGC 96) ( COM-SETFILEINFO 103) (COM-OPENFILE 104) (COM-CLOSEFILE 105) (DSK-GETFILENAME 106) (DSK-DELETEFILE 107) (DSK-RENAMEFILE 108) (COM-NEXT-FILE 110) (COM-FINISH-FINFO 111) (COM-GEN-FILES 112) ( DSK-DIRECTORYNAMEP 113) (COM-GETFILEINFO 114) (COM-CHANGEDIR 116) (UNIX-HANDLECOMM 117) (RPC-CALL 119) (MESSAGE-READP 120) (MESSAGE-READ 121) (MONITOR-CONTROL 128) (GET-NATIVE-ADDR-FROM-LISP-PTR 131) ( GET-LISP-PTR-FROM-NATIVE-ADDR 132) (LOAD-NATIVE-FILE 133) (SUSPEND-LISP 134) (NEW-BLTCHAR 135) ( COLOR-INIT 136) (COLOR-SCREENMODE 137) (COLOR-MAP 138) (COLOR-BASE 139) (|C-SlowBltChar| 140) ( UNCOLORIZE-BITMAP 141) (COLORIZE-BITMAP 142) (COLOR-8BPPDRAWLINE 143) (TCP-OP 144) (WITH-SYMBOL 145) ( CAUSE-INTERRUPT 146) (OPEN-SOCKET 160) (CLOSE-SOCKET 161) (READ-SOCKET 162) (WRITE-SOCKET 163) ( CALL-C-FUNCTION 167) (DLD-LINK 168) (DLD-UNLINK-BY-FILE 169) (DLD-UNLINK-BY-SYMBOL 170) ( DLD-GET-SYMBOL 171) (DLD-GET-FUNC 172) (DLD-FUNCTION-EXECUTABLE-P 173) (DLD-LIST-UNDEFINED-SYMBOLS 174 ) (C-MALLOC 175) (C-FREE 176) (C-PUTBASEBYTE 177) (C-GETBASEBYTE 178) (CHAR-OPENFILE 200) (CHAR-BIN 201) (CHAR-BOUT 202) (CHAR-IOCTL 203) (CHAR-CLOSEFILE 204) (CHAR-EOFP 205) (CHAR-READP 206) (CHAR-BINS 207) (CHAR-BOUTS 208) (CHAR-FILLBUFFER 209))) (PUTPROP (QUOTE LLSUBRS) (QUOTE IMPORTDATE) (IDATE "17-Dec-1992 14:28:41")) STOP \ No newline at end of file diff --git a/sources/ACODE.LCOM b/sources/ACODE.LCOM index 6ed361ebd6fcbf96a5948bb11cae31cdbb3580ec..032d6daf94eb452ac9e4e7a346a5bd52a22b6aaa 100644 GIT binary patch delta 1403 zcmZ`(Z)jUp6wgiC&ird5x;3=8on_ReVA6N*`;#=Av9B-58k@cwlXPuIXtOoJ*1nq3 zZfcQH5G=w#D|agnM6uvE!Dhja8l<2@MrBjP`oZBRMFj`8`{cy?+H`G&y)W-~&+ne! zIrrXk&dqI4lZ1cHHx5lM*1*av>!czJqe(kK<7{4)69^;ow5^6824 zbSY|_pPikLP8ySQGtuc%(J0MF=gOC6$4hfjRim+Z@RZaEZXa|9)R|eXD+qwY5dlX; z;)4sOtZ}jklU#Lxd-s&)K@7@}xMUcRo##py0hGOzg2A8fu>HdK6uK) z#)MY%CVN$wI`m|*5nZjl#C{jL&^T+uedsebj+g9S+RT}2oOyt~uHT9;TKIQwrD9oS z$H|q0v`5%w|9!fTdW;74Y4|Anhm0?LXz_>SZa9#trfJ#1-h}=fC|G(FC5ghLC^0NU z{Dm~&ZVdTEQjgJer`xX(5zc5-&*ngq1WwbW()%(^jn_Rz3 zy0T|nWJ``ysGr?(C`X^zxsw~MhJQkHnkqG#smnFoXW%@6?y#5>P=%G8y|yw9vUNuX z`_|clLhP<{2;HrQT#d-{6OC+4{Wzx6LfcrOV*Q4t+%dGs-gPTTXE)tLh-)>6(dTTW z`85<{cbWy=Jy3tH8?7~}uT+qY77#61#|pJEy<*v{XXZ6I%dZc)sST6;Vb^)NHes&6 zV(Av_zD9ML+s>n6d5gW>a;!O7+dJ4$k$urp!eKhPQrRMOv>yI_9({^tHooUNTWvd0 zuXCY{8EDH+N7?N|hi#S3znI}^@A*#jtW-AFIX`MTY_3`SqNrfV#WU$l5=2p!fCC+K zD1|`J^>H97kW+g>Bw?lcwda+_XJyc}=LZMUAWD)9yHLb1s1Na4;buMx>KgC~~lj?2p4M%j{Yq3~+?B)|b{*j~arY*154|ugUIkMWZ zw>Y=zy}qA2w`jCiS@b=$Kz2(NL_RX=WeY?JLw02-V#Tei zl2pwCWml=RLPalxbipE#U;(Ps!HBKf9f+c40jLq8LV$#XDilO2#HQj+;(UY`<9qM9 zzjNl!(`EEz8QmTuFC%+PD1!YiaJ!~U7cUoz`5crk0eOhR)_@1zzuUfeCBKI><*!{X z7N!ex#fAO|L^X9-QesjZ3YWk&lFt?M3xItANC}z<@%dsA(hF~w=H~!7uTr||W&M5( zKA+D8xi{zNAlJb-izAqga3Pnc$sJG1lBh|7F2#WKqhHDS)(18ZG_5kIe7fy{t?`W- zB-UH#&#;Y=hVD$`-+O`DKglOuy=197)cD?h@CJF@eafn+C&-V`Pfj_HqBb(@>_Y#N z8D}5*p4@T*`hwhbM$r|r>Euy_4D^hnU&@O;waEUH8rhhAJf*1F&Z(?X^DS9|7`j0= zfJbMDy?5N~(i=ke$!hO4G(S7uEAYqH{EnpRXr)wlOBEH}vyt{#V6DY|FG26Ij&Yd(p!FaJV7 zom?}Xog}5cwiE3;bMDYm&20V5rcUmJK2;~H8}1C*dPwC)1>(TcT4AnqF_H9u)zXbDHG_`7jyl%65?@)T z>=hx02REta*U4{=*}B$TE&8A`9wB4RC((Iwy*YutB#)YJ*T1A5q0q7kK}$#D?^Ug6 zp+RoFc=La_-M1s^n(_R2LbVqUkw+mXxzIAb_>sjOrUZN@ z6W=x!2;x@A^ljTQK^H_xmeasvAWsI}60O%HeN&9Mj$aBx*JKy=v_de%_Q|U#cn2szO`E*14)lZ^kHJuWniD)FdycwCB72|X9iMe=e zA|%403tJa2tu^W^Vrx@`L=cUx{93A#`@-i})^;{d&`0dV`pVAk)>dQZMB~E5iN@N_ zr3+iz^@-!-Cw8_jZ(peIoS-4iMC$nGqE|*S(0HV$UnBg=3(xBEqz|V?5sHK8L~RnRo@uC>mSKEA{Q;p;6(k5)4%{ z24DyB1^%XLrM!`3x>(*Jj5B6vSuMs|s+Ad(+(O5{OlleqBy%Z;erB5gF z^NJR&-$cChBV`t=1VfOqN5}%Mi$QDWHCV_w>$^}kLhGiHi}e?=hF(Zv*;@YhCt&K z66G9!!GNhmH6aU5r^^+?EJn(_GRa!GOrxt(Im}|Mn5?2sB`6rGNTr&nRunS4mZw~I z5~jPx(&t2|Qs3QO+k91AzQjbgyZmyaPE<@B$$?z6r*C7+=A2-T{RK2=K>X}zs|L{OSweJgcIWY`I6o7r$+7_%hs z$*3cA5d8LYNgK`umL+;kD(Pyvl1!A+o}?pzv6ntLhLIArd{s|m8G zk&l4xYiTDnI14~#WhPTG<|rN$!7(PoNIrc!ogc%*7HTIWBzn?i^#f~@P81wyy22c( z3dV79d2Lf{^SX;yE^l7oO&M>)S+G<#lj%x@C42cz8Jh=B0)NW=fIDxx#{(7qahM`rH|_oYI917&MwxL~AWv zBAZ}}?qWi;9GAX#XA&H0_7E49lNNe713m>s)0o&@~RCmT1b?l(`pQhqY;aM{uak}H3~p| znPfD;jTEcq;vzcN6b3fJJ1ZEvxV%vpJD0cX#3;Ax|8Pg_Y+bC2OWSLkyVgDv%iCL* zA)0w;Qi(=~!Y8S1?bf{*efus+m$I#jmV28UorEbV9}=Yc)Fp zO3JU)@dSVK=n@4yH_|?34LzI1VuiuyCA0d548^KeBV0sinz*S5DdFV;7A6+;8#lBlFntLMPN35_I}r~p#^v{5#TlBeMT zfdZ{#bQGF8)<2G=2Gy4H$bfyPk<~Jdq@^0zL?0PN!Ji zwHu%z|+>58ljF*ei&umQ0M-8H0L+68978`H}tms6T)rCL=|kKAk?W5o%U z2vo!bRJXD<7_FP*iM_s>s?t!)7QiGk5#m#o2%3}h)U2j`a-+dct1RNFSvD$5B1-!3 z(h{#yxu!KT-&nxs^Sy-sd`}JeeM5u(%*ywDn|FObUj56>Pu>6V-@fN-X4W@8{12-? ze9xB|^kD^p;Yo3&zt5g9P3GsX04w`N3=y40ZqQ6fB_{;Y@=9oX;?~^-tdUgS?xEM# z^wRJ>HmO%N5xnAA?B2OucZ^voCJN9|+xD-GQ5c#;B>{9HXAvGYFrtW%B^%4t6yU5?gt=48#j)Yae$4 z#HtVsd(XNBVcwNor~wa})I7+h65ro z-2LN5;LZzsw>Lgq-g`%K)|m+bt&%8S#F)!^P0_(`y{EcezqGZzD=yY|SGVAcb4}Lb zyF66`Vqpy8rkF}V(KkU!wdxqw?9%`*u(m}|>XrKh{TTFxqqAbsEEf`0P+v6KX&uFs z2-P;%E?#QXN!^00lIT`!U5bmV73C#62;pKqJVi#>Qr|l)yBilDVavEjKA@!W@EUmt z8jo6#GhU?!5i{(t>Lq4824N}VQU0?MGG0TsuuM`EAY*ujQpSiNWQ>%B9#W-4O}1dX z;}!>yE-=2?gWP7sNI#!)MRWi`*)hF==xoZcvQG;CM|Dzk01f?Nc`R!tNYVuhC#S1K z4O=tbz`NKgbR*ANWbqU7Y@3Glcs*#V$a%;Trvp$Hb#{?DLFwusv&M5`EyyFI&%2%r zO-||KpdRmi)uBfV`i~%jI&`U4$<5I_)a@*aIyE?;IO^058#~@Oc5P;t3Gnw!EUCSv z?H$kAI7L$jT(q!d_qy%R>KTEB(_-~}jI17Q`ot!b=_6nS0gET$o`ajXR4r>;$P;)a zxN4jAU%dp;rEDR0$Qa)Kt10-yy)An0ZVw{I_J_2Ow&xy5o_WQ}!C)1qA@Krtd3z;D zF^@tQ&3E@(%c!$PtcRK8U_~O-J{HTc_F|Vd*jap$=eI~OzdK(!32fx~KK*3gi&yoC$~g>mYMDcwlu!Sa`VZ zy>{R%InoItEQ1D!(pt1YZ11T}7J5{1W8P~`CtWB2#-{a{z1)E9!&%^d1R2@hn~Jx) z1xtJ0OGp1-dyn9KqaFlh(Tkg-d$eyEtKaf9del9j{PpMoqPM-&wf$QFZZig>ykpzl zjKB8@%gy-4$F!UA4BU)sw=)~(2b%Ag11rUQ*Pd^#zIcAH`4UN}r_LW~4h??XJksWV zG>_Q+$G6NQa6mQ-_-hUh_nSvrU6H>}uE?(_@8p-w0s8re<^bH3=Lh!wnGZVV ze7bnDngQv>rjbP?Cla0W;DQ3a&UWaPXg4-V@~rLb!qq7qotz3KcGmt${rJ^q(^~Fd zO^KH;Bi_$Z{*LnAV;H^b-J;gpWNmNWf@5zf-`>n(817M93|2~n;6ONZEb=5*5m1+G z(UIf^%8{xKBATb{>^CHkPNAIAhw=%dpc}F@)ZN*&IrIxyDC(XvlQjy<%lxnQ0ab}k zyF!BN;@bAkuAoduvGs~rwi6Xt>uLu9LJApJZTWZ%1j5td1+!L6S#xbo+XJf(^ITgW z2qYf{IeWw#X_Bw2)G}5e9Efv06tStvp2%~xVAwmam(DG09aWcOz}~B+EAL}0XZoVo zn9k?>9^2WdC&3V~t_GR{ZMq4D(wi%htydz*5ne`i-1bI&J1*8Tg?+&oK-k=2o*Q-|dD^&8iX?7gpN2IsTi;fF6~xMs^o zkfqMsA1kbnWJb>VmjWAiZsv1OG_xCbZtVSAUwC>32~@?Dn3xkJ8$p307E_W40@apD z(@~L3l*QDvh$9zIOhp9}T)~qjQGk@wDuTk1NY$(&V=e-0;GgEjosyE2i1Y9kYT-x8 zmHK;Fr6kITWQ8*^M@6vB=SP}(NHrq6$kE5Bma37GOn6YauQ2*$>UD&Z6p(~SDcsh` zq-j{LJp~1gf^1N-0yKcEKxuv48cEg%1GeC9Zy9qb)>c#10&OYlR2e$1A>HPUo;1~N zv1b%mL5Dlf@s+9jA)7M_7)xxE4WpoNjO_SILP}dOL2sN|sBW=UbZr+p(4S?WFeO@x zEZyPWibpHhAHh6PU4X`1_6WhCM;5-rQ2+e%e=4;=BCzn3UUz%**og;L`kBU&hI3S- z3d!}HvFjSss^w06fa2*fq=s7)>VA5%Qz-OMwDWaOOt$;!#$H(=Q{-wSHH=7l!9=9i^ivj&p}=FVfy^TSQ^u@!Up-nFIX>iHw* zAJ-<&NYi-B9LW#+nuRZ$Bd}-!P4fs!%*SEdjI`P|Z;>(cWw&kf6>Z!6j#d5`Rr>?; zF|v6c+xw@=<{=i$sEs0pSY>EbU=ko*LlMDDjI1Ap6o<*Q$ zVsgg%8l7o_S_P|@AD}|K&k^np}vLnn>Vt#dtYB2 zoX;ihq>Nnh4y8N!GW^LFXEO)!zxN+~;mJ8VV?rka-3MAG!9yu6z9?XsV#`2x!yzxS zH&tpqrvpvtUn=IFlqkCu$4!KIx{X>l0|4*ZO3*%5-0lo zG9heZdFbiBMj-Q(H>WI{^5W0Iq2W}ihu7Lc2)jn4&a$x#y`1V zRmuh2iR?1Ze~KILx3rPtFfcqAObEEB@?;e70Uc=zOfaR=`5aX);He|xbrgZLVzF^e zTM-s%vFMa`;l;*hh?%C0GBg_;1Rf`jg%c9dS+F1Llv{L~NLHFsQYcPO(BnlBwdIWL zI|}Nq6>;Jb!g6wg&Ul?Hg0syCsdh%kr>t*0Ry%i`og^4)MKLp{noo_l??o{Iz@_&N zQpTDBrVF_-i=($rK?cg18@FQmk`X|2orF3ryRh4%17NTvQBm&zIR{DVd^Dy#*S`zh zdvC?geX|(SJFb$3l)yQZgMlaW!K-N;I-}z>y0dVcWdn)!_=1@_=WrA7A!ca8RcJJH zN`yBij@P_Hf~-yf6={Cl75$iQE7Gw^j@LdC%Suo29` z!1-Z6>;!W-0NbF2rJu0ZUa|DY!LA*JAcZ`_A&)UHcChm=`uDzOSL1IFnVl0Lik;8S zd~|khD?5svLt(I3Vbtb@A_ip*3#+u;xj83CpN+L}^qCpO(c!FW;q@_#qfgCfj*iR- z#nF)&A*n|x(CR36bUdc`_?&KZP(F@JBHH+PbR5iGC6H)Fj=Aigk?Z~N0K8o8f&*=F zDJ>4d(L2N0o2e6He=z1QY34xuJt#etUHH4in^W;VsQPz67B6S%Z zDWYNv@;JN0>>4FpK4HGK z0-KvOWNAslAzaOr%`>F#LAlczR&+*3M{eDAHbSCwQ;NJd0CF3L57Q~M)^pKU9dw-s zP0Qmd1DYUCnP_jk;wE&;-1k_>{+ zup>novFMR8#;*EI&j;OnD7F7WlaZHTS6$W%M(1KY>6C1wvN!yFH{Ai{TkOv#H zXCD9dqs+l>q3oU8#g)RnYgxG92bzXxym|K#?Un9jJH zMBp|yXg9c(2H#_>&bp}tG$*ETRHcYBDlLg7tsuGRsg(d0;j?Vx(O9tTBldzN4zb&D zmE4Xu8h!9U;%ndX%|<`Ip8m~7|MIQu+eai4n?^1#<!03w(sGYVm}K{ zNa`-o)2+*REGpJ&kMnAu2eAZw0x^XETzO9i*blWeaI*QZE1}VNX&Df! zxWEI5$G`4&x)b6ybKUvy3Rsz&9$bs18I17#0xKO%@lZKEJo1(1?%8gDd#8OIH=(N19jgL6(T)sqyuIei|H;epmIu)#PKLmnLIt?Uf zFJA{3Q$VkOGvJ8UFm7ceX+8KTv8{Q5;EjPD_GV_#c>XUN19#!5el+_R67c4{IJft= zAeM0iLJ7POn0~myKkzqcf1JJa8;5Dl8-4X3sj5;PyH;5?V$aA0bWKHRh*{mtr-@=-{bmj>2rk9A?SV>=c*Oz}ckbk!y z|AzVxGfnbF!Y%=Kcj1AF0JMRu7!PAbAY=l#Xo~5wD|9fyQeq4@5EXDe9$!AixN(FR z#+c+RF6YL$z0n5%wts#_kP!M`QV0=8Vy=W3hjRImOI+SM_CO4gwq$@Ahva)a3M_@N zq#g}bFLq}`)5h%VN5tx6w=VVpe6}bgpct3B$CLnL&3VNfm(8d$C&hqJ+cbWz3{rCT z3JKSEq~8jxNizDqGeH2Octo*7iZHr{XktPF}bb+Iq| zom)n>5y%g`aQfO&N5dS4Xmez8j!){tJ%|Lz8xAP*s+_=WM9|*C2=ME@k4UciigGbG zDMD9IS5GfDF4yUHgR9TrR?-oIBzYX>bn-KR%g9vTWTOR2E7V`Mk`<=HF)Ai(X}E|)9_ zoOc2CfBVHJ%`40}8I(+B4H4pP-~cU4T4yC5cptjV*Epx$io3 zAkEX?K`9}DgbN=^5%bQ~W)|)m!s1VsX9m|GB{l_;YS(aY-cEg&61S-xt`VUdJ$ERt zeY?Ix6>tgZ&c$V1Hi!H4>aX%GpFs*sQ9x0J`lb6%IV8P?ABR?gdzL-qn)K*_13QJA1auroa5You#1 zdy&RbB8_?RqaXc-l?MUC-WsvoN?`*tqll;JkRp`2E%E#m2AS`%>fnjmF_T3!j_C?BC@I zY-ZigHx9plYw!EM@C;&%r3C@oYT+ENO`Ov1O&024%solOH3>ojJgR8qzDL$cQ|<-| z74quQUMP_3#k@o!LVBOc;N~3OXMT|!6Owftd?pM7&A=n2#zpS3qJmuCl=?uhtJ_u| z0C)ukfe%%v>jLPiY69)KqMrO?3VMtpKctlu}6W(*p)bGPKm6!PDd`DOnJ zi9~u$U?4m4?5q_EBSe7s0AC{;ac0W(ralQg&Dz5u;aW6RQ?D8n?W(@8w%5|lQNZ4| z05*mK%BLo$y7%~s|NjJF!WtVNp8LtaT5U`+SvKGPFGgknat@g$P$rj_NWquZH9{Xs zzG*>+m?vLwYX$GI^(Gz2Vil=3I-Ixj5>jAobteS}8f@mt3t`{q+Y3FDZpz^8d0nDL z5eBSwZ^8ic;fs@FnnG0C-XhXKpe?FfgDpbYH&ar?WX*wa0VTgHE?V0JJrH8wWZVlW zU%=MT+vV#Ym->%FO5-ro2jl5^|IKW`e@mST{J69gPTZb1)^m;i!a#F9fB#!kVAlEf zxy|`u&G-&|E&dtlS5XS9gSS(JJD*w*v*VJ-!;{1G zSU3%eL^2gZYb6)2BaezKqg47d9rjSR9y_;y-1a0XC*yY@*uo<% zOc$}P#kob1c0;w1otH`XT9aRbMyuB((XZFUSo!n7;QHM^=Jj~vUEi%2e`cSMtW8C|CZLoIBxOrwklDqA@%jdq^G&b&BrvzkB9=asoN0M@1-P*o; z9>}3nfex|*6-tF~1OZ#03fQWJ%fRJ%Y8^HacrY^#c=q&a@J#5Y8!M1(k75k~>r+cY zb^9Wc3FQ)_A9Byx2w=Qvk6RV_*qYAZHRhQQ`TN|PJac^>z!?KgTd;7&mRdKcR(7Cy z>=8ehyQ}=LE2|l>Lr;ozFPd`A;pco7$*}K;Nr9O=fQQ;7vnLQc;sbith4vP!VFIVz zzz~f}#~FLFV+VLNJ-9czPS06gO;Bg~{>>fIOh?d>fb^u4rvVPhE=%wMf=IEGK| z^MUc63-26^@X^a&aMf4XP}-{F-3q->@-%0?N|fNp1b;dAClWP-8AH=LaU6N(L?6mg z)J4h+>xypl?1$3ZfTdY?u@|J)(ca45*S)Gm4{jG{?RvmU)=bn z?|0DMV;YiS{pAR{{VXo6>2LJkee;K3>~DPf?w8CXzs2!W-W>e=@jK>YKl&T~pR*7t zBj&IyFbBUij3b+U_rGd>R)Gktm``rp0rF7Pe+LNs=1>26{rs~(==U|vXV>qp-p#J8 z@nqifWnl%rFXzDh$*=1}p(o7e%;Wd2jj8n;*Ko(MH0JmnGp2?=j)9Ih_kO6>`~Ppt zU+f4iQ=J>+e}7c1(?8FuB-1Q7=nPK&U<Wdmhd_?Gk-dLoI?4w@JLJ(6iYj%yv~}MteynEvP5K zSKZAB!bvNVGAT9qrKL(WS3n}t#H_aVCtwJ;TQagHke%dJjDB>n!Y!n9v06SSCg9D& zk|1JI%cqL)Cs^o-S?Gzuzbq#agXmJ<&@P!a@?`&-&58fs>J#>3Pkub}ISHE<;F)#s)M zUv_FnF!!=Jxt@X&zG;3vUN1n|zHIb8Md$I|4&3YWne|5hiZKAExO4>CE-(oAgL$_2w&FU6&JIpuYBYknmyN8eDnhf~sn`q9bAVCv41EEY3hms;7+F?hRSdy* zYd#Mr?+2Oe2aQ42=|33iJ6v?r=k207ux<`gyod6=usgI`B$YP_m<;W?f;3X`tLA8Cjvkuy&D;=tylm6A-o@kVd$-rA9dB-5lidt=A0 zXgp5(%*Q#=5JOKO$rHg9oT~ZubMrE*a-K=7N;vxLlL{Gq!i=rx^qpFNdHxcHsQTpv7v>{Ncn8;K6lmduJQ;a$IwK1uFyUB-*Y zZB>y6*3li+ke!bTzaP6lka&yt_HXg$JR=nHQ2xrWa2fLZ-9H2K27FH0jlYtQpFWgh zRw_Tahou$eed31y{n{}9&2u$b;kRY&W}croJCNVGSY9CcVy@9AYjIO~vD8vQ_9j31 zF{d!U=qy(4WIo!xugNPB)XATMECuP{`dGrNx^5~aqv-k<^e#LD$_TA7x)B+#J18dc zmDh~Fj&s~ywTQwWq3T5EcvYxQ6o>JtpW1?2+9nG>Q@Jt%w* zl~9LR6~7%>TtFlW2Y*6hIw(SwE$g+()&m!J=RHD=ak!5rL|dIaa9U(A`|H|*ynWQl zb$BAo`2uViiV#lDhVWiq6`f;HLv9(<3I*MMS2j*&sv?YIO`DhN;#qOFzPVgS_ssNww7juhWeU^NKj*K{U!R_8JL+`%QP}DBqOjZV z#OC+IsM$`M2ffHtUbT7^^ZP-w^}KnA$4+z9t84|;Zm+@qE%Z#HwyD(WVJAHa>$~-u zsqZ%GPa3k=1~sg&d!dGKbx#m46YPk)*dzX_ZzkSTM_-%LQ;Ed zcE4r6`mTrAc$F?!Pv1?hW|R5T-r{sJv#0@_r^NJhu}nA7tba6n`}K!U1dY?Tlleuu zQk>R{#z!Lr?~el0iu*63VG@!)VH?EXk`Y(S^!;>kZHEvk464-k!~WuZ_@r)X^~TjqF`qiR?2Be^46@wYyZ6Pt zFQ1v&fBf%%J$UwKS^b$nQu-78Edgsvhf@Oh@X;oj&BI*}OjFzAk|SUN5)6_d;NE-4 zrhd2AGxaB?(M_V`u+uknX}*PAHFQd%S72seu-@QphW5bJId#-;hl6;;p93R=IEW6r z{k%;mOMbYfu68TZ3xnAMWb5`1L8jK<+`IQ>^FJ3P!oSO3<<#%KxTjA?f6rIH`{E1# z@ylo3*_Z$Q!@K{H*C5*?!E-b|(5cPC$3mfGNRaoGT>5~$11Qi9Z?*yuEU21?HB-T! ztUof92NlSx>Kbzn?O{%rDYq#$si}-aLHO;U9!Ua`N?y0(;{h;BxPnz8Xu>k=G8{C2 z{IT@LRQYC`tslSp4!eepzKm~O|sj>o2T)a*k~3wW(~@cKdC5}7zTiiQtNb7Wpdz1~-qK=C4ZN(fe3 zi_1%>?6dTII-jlqc%j(28!{GI1w7=*6w)rrXCB8+AtsrU=Er>3T1k!!8Go%&2?V zZ*t|*3n<>BsP$Y2g`@62M;5YIn5zxObDiVn@VWfJg4kkBZGgHSb>n_G6wb89!y#9< zt-4HS+;1i51N|;gg`=dIj4Uy3W6v-x3Z~!V&3D)&>3Th#UzqDF5xVu{WR_BjskaNn zjRyrHWI&kX=JN>jRS&>=2TE>>gl!u^fxu^QoM^Vml`sLKqh6Ev7&~ed{Wy;LdVsr%U0q-@54na(LM@=I? z68*=$45Se{?2ztmVZe|wt9_}`deJL=cmepJeq@+BykT=VY`%8WibOyo*jAn23JRMK zx=C>WbaNjYoYq%o=rj}W89IE}gz~aWf--|}^!oT9?iro?dGz{aJZ!s00SqoYd;{yI zON$NxiheT*t?Tj^gi<<_5X0h1(%KdkD?gz>A@-dFXd(21$-hF#x;VUx<{Q7+T3S7wFC#9S?>^L4h*%w)N^hKXJ+ z&}*_bH;Zd?I++{#2PT~?XE)9|4n)Hp$1mD{GSwf)aRLj4#psdLu(-DHsb#gh*A+d% z2E5L?+DF^jSM(MGs9i`Plx+gxg^{ImM@Xk@^I?kU2eAYqD=!*VPbGc*)les+zdY0+w+Sqt-DNB;};@_q7_tWKK zewohKR-r+QDJi*X@)|0fWTatY1FZUs?lA7FPQwcV2(M#n3vM0-z#1q(YH1@Fs2fq0 zf3^(t!(F{^^)#ya9AHm8=r@mP&>F*to{OpWn#Tw2rm5zO2HUXX{dN;uH6AB}ak7p6 zop^ZMOiW@b!uYH5r>IRzUYogl}_;N*IXa^s6w4 zPyS4%&KGNQc71t8FQf74z94YR`k}V{GWhRu;d~r2d--d)kp6T9EG!FrhY@@IQyWnU z-Il{F)Po;#2YA%u3`Ttx-6dw5?kL2AalMt$s(N6~m;F_&>dsH$#7|diNSn%3-yB@TqN1kSjSCeW$nwn{b8>rUIte0a5=jIpW?>J75iG^_KC9nMbBTgc&;* zt=u164mz))1~mihjVu7y9Vr)T9J<;9$r>wLe* ziuV{Mg;9}4BSxhWLI{P-m>Jm(#B<_KQ0L*dTDLGv;sm}zC|yM&WE#;{rrM5Sn;8jq zv5l<6=zAkm>H^zXLDatdMFeN62s%3okm+JBQynzBLkJuGr}JZ^yFvvk3Ma?eUj!e` z-j->=ZE|g`=8!YsA51eIL1qO5nPL|iHR5LBh45nWR(oi;o-`_X)a%Hk9hN}2$H)~h z(HFM+04v#@pbC5>o^wWHFWREhY6+}cr0P#pb$d!isT*3~e}rU{4NM{pkR75>RGUFF zkuX*IS{d|+M+I!l34O{sjb4!Uwu{>!cxxRT-BN`(4AWbd%f5slS%d6FkyWu~o$heN zkV{-mjgi$?vs2_DqxE+>$fRV3bHXr)>HrJqU`bh|%P`a*&=cy3pwB|$%@sVN_Y97i zj#*9M?D?~a^8?AGkUNLEYMp8KEVds6P=oB=3O@P@?+Svh@oSC=g5RJrUJ(cw7Kja! zM~3dFSuYH9!}Jnb*_(zQWxiTLXsYJ(?ihkTJt5&};U3h;vDJ=(>d!cLJm&NT$ z7HST$Zt)g`TQdA2-zBE`%PH3^zf?vg;tvJ!9LLXb3;vyDl?g-p(+Do0!AT0foljOX z@XXAwFHb<5Gn-8?h=XNaWWA*SbS12ula=7|$zuIh8kF7ia@AHeG-b`0kq$4}?*i#u z1e{>#U@Va%XRy%3$T9$Nf>88yN-h3j>MscRIJevEs~OxQz{NJTxmCF4GS@{qPnXPW z>Z~8$rgM1ah&GV&oXmJ^a=t{C&&l@Ij->2#<3>FQXvxyr-K)%jhpQgyEqR#&QbkVE zo5W(+ueXfZWITl2Z4+wZ=4ceRlqDHpjtEvAQ12j98K~-3L^9QC`O9sUt7PG@L+I{l zGr+ZL=rT?ukxX%)F=5q{jcm`Bx!)YWLjEopz6K1~D{W|i{un{0r7M&(Q>N6M zKWaaRv|Z#*_%b^QGolNS65d2X8S?U+Ot(0-s_?n&sB>oQ%)n5Bn?h`$ii24uX4FJq za~sgD73u(R(ZBb_M#7qQhp-0*rqEK$s`^c$0gvGRLEL_A_y_&L-YOz*EaRqOW3O?b z#-fVI?hx8Y#f&fBym|A0YS2on^`JAB+aAwMAPZnJMFvUOV)oGjxG|wFE^CyhbZjjR z4KiTVPHw_J?juzU>bcz~oXJ+UqFy$zey1SoRW$z;3J8}?T9#*2)NNc`qFUD1AsN6U zuw2aERcm3+6gWfz!)MUQ>Gw=IY%PS1vI~Nx=JyuaDw-wpISJd$!qQps{DR*=+?Y)G zoV=C9O$log;3bjCB}PPDcoP)S&Z(%V6rPKTDH&)bgR*e9=s{aZzt9(}OsZ71ex}ps zMbDl`kOka!%7#pyaw29;KGMHb2H~arET}oTd?8dNvf+MW6KNP84>&SYNM8CKZ<3>7 z{L*=`GK=Qt5l(bRM^W46h>T{8T*o^?f9xl_s{R9-Ib*5-IxX!1=Vjo1B5WK!kOz`y z-&mlaGgJbc@=?bpJ+LsjpKyh>k&~?g9=F931zOXBU>cicQ+0pa5Kzk6Hmj_Z zP>kL;?2D=TLMkMco-Sy$g0pS&c@T*K(&xv}qQkpSYwEiXZICN58-Jne*gH z;z2x$5HV*A%yN5qESUI}gNTO$aKcL{zVG44%E7hE z?O5Gm_PJ6_)ZvF>Y!r6}88NGY2)dj=m)UOR)d?a~C9Gd5PREqY#*~g}Z{7@|=s8&z zI9QlbDCX5T*f)A7USCyG6qtH(SHl_{Krr8{hfK-D;KV4Vxj1@Z1U&bT;L-)EO#YR4mni zjZW@F$ZkCxzd78{#qCY%r7F{o%&plG>NFuxu+Qj@9@%sZ0R5h%xtfv63oVh6Gltdm z)zxB&a2bar%*wmz&>N*c;~@?wQBh_BAC0V6W{-1*P6G|voE+fhhZWEebULE)CYpi;NF6Py4#C*h7A&})b^l629qc>X5g z(l(9}k5S_yC&)tH!U-KL6Y^UvBw3Ym;&+rit*R&Nb~lKMs#XKPj6zbP1xpOV;Ypk| z>-XT%_mz|jFOQMI|5MWfo}ZI?T369mjvb4@H10wTY)a5o1Kolt%(q& zY{TU{JU(sS@pnj7MhS>&QV;ApeRhA_f&$5=_U2s541t={g@Zs@(OfKyln zWoP>U8g*Xy$dao6(Cd8JIWK4A}2xRk{DraA$RZ6_82veid7ONB?28J8(wux zE}_K|o9bqct1#`hB`BN%Pe0j!0cy&@TrAb8;>^~3eqLC6=Qh%7Oy0u5xt!dX4-=d= zB3Y^h&HOdNVKFk@sANLP@(Qk^X7F)dhQudoD!yK0AUva6bRF`+Ym?3w*B5V@qYvy^ zh^G$;t}5aJ>bXA;!8-UML$p|jgfw{@1wWrhwRjB0AvxWOrA&}r4MF?J)1pE&PEd>p ziDocL6R8cba?tnMrB417#mS#8V4&hFHS{lO2ehb=%W`-f;p|GL=j3X|os9#_KCTxZ z?dtR@Kb|g-b3R?8+I(|fkHeMbY6U;voGsQ&UNf7nTt#)v9FFcvPE=6rF<;TuT_T~a zrz#$FnxmlgN4x?j+nKJ7<$s1QZjAD@kb?3H!m7w**6OI(HdnjW`Cq9#0`b<$^v&?besIN1HDL=aS)=xICK`R0o`200&rDpQIwvr+I_0 zJ(c7Mrco&_0c>;Ks!!GBs@1Yw@*z0;0jFa};I9ev@gf38G?kHco>KsZ$D!Rg{aTl!xm^aAd z6;=XVvZ6T{^l)UKr8RQU{K-l)iyd=fUZ}%VhaPitZ&*^;wjyMZ!D8n84;|Dp!`HSY zoHBshA-IK#Xx^ZS4sb#wB+2Ig98n6u=S8GI06L|FfUmG2r_GTD9Dk7YLwPR1j_JzQ zgh(AD{OO|dRUJ`Ot}?{1>Yx{Ok{H1hx^;RnOB`ept7zW5L1)y@tJRa`c7sd}WZ|Kn z3>BtQjdOryWbe2)-0+W$d!n>B3UV8=J1y3mHz>;DS~6A^wTg!XvK@V$DpOfP_#3oX zms_npq%v~*h4IyfJ_M>P;iY~?7!kMZb6+|Ozycx3;?%Nq*6LUe(-Al*gVqNUa+3>{ zF50{WV`b-ZEk3-3vSENr?TvYgUKlS4&={{#%X+~R=oRYRrsq>w>{&X$kV9)E+TP-T z{3ON6bBYqNGrUBmZncI@pDfP|Sc;n~my@;F?-D(*1zgM`{P`sWX}091mkq+i2U119*8OPcJzq{{{KWaIuzh-ZkbO2V^BZ|5n)93fTt+t5K9 zQ9=X}%7bUpj&W;CjzJYFl{!aMURW5Wt2J)#d7wNH*d|E$P3AX?Ih|NIwgiw8dKbEw z+f!2nSZlt)%Q^<@z7S{#Tfr+Jsf&O^(b9{Qt~6O92k6i8Xp4xvBs$)j60F<8a;&4=t+M9-@W0FoZeIC?|u;hrXu z0=?2@FHfXPWUCwIYI6E+f(qqNBgrjE!6R}?GO&!^W+^>DDi~B-P*Vg7Nq1X}@0&f) z7z~rD0#re0&5cbsSysqoIWKf>*R>28xIr)TA9-omXZ|FH2nf8%7$)mUhf=KYx_l=fMOy!j^K&5dD$HHp?Sah>ML^qFP^pgEXYSy zm;6}bAOSx64H{Sh4>gAZoR#RmH8cosA|u+w2ThN2Zg$i-U zw6CQw>v|4VxV~oP=IqAc-}j5@8Ec-+Rk{={IY$BgGX0lpL>F=jf?7{T!g|Z;`f4^k z#n_c;he(G+$8fAznH37gJEki@Y4kgB5i^Uz9te8&oCHTLCs^~wb>K0H6xXk=7V|SA zBdamSM$E->72P(p+(%Gww3IMqU^=u)Zi+g6zT}Y^Zco^*ykjzQMk$dWGI|gV`3n0E z_t;wTxSs?#)qaVexQ~Z4C@$g*TDbfZk8qC;v3Dm16ykro{+?K7Ac|5$MX3K4uY;0X zA})G$V@dRMlof-_Yp^n>rarU9-8xhpK-YRMR#)DJ2~(_qOS_}ozt?Q3b5*38AU+Pv0BoePbLB{iT@F=H=_hi}k7*# z0`x#ONHdT~fGPePx2KSi)T>k? zF$F|38GG}lnZ(CPys6l!DWzd9Uct%+BCvJ>nln!6E%^?jP=gzhaYkZ#$)2hG%&Ce| ze>CjxVEu;gWb=Q6YXz1jd4CtdD4ZJtB0I|Wr8~Syl^tRKl%9p$1E}#&XB2lmu12vY z(w(-{^JKO-edoMp>{k@e97j?lyQ$v*0SYB(4TfVm2Sn71Hqf)(W(=K=Rr=f|Ja7I{ zdaCn-35xQ_eISacFc}fGUX|SMgJD3gqOS>9JHrUK^%(z@-j!hC0!4+`*D3E5gk|kr%i&Te&-jpB224fj;ZfJb z51&3i1AM<(2A<|s=P7M6*?vWn=?jU_{w|>Hu))S+8OsqMc=p&d?3mAx13Q;lYXE&4 zE#MN6b=$%bSMF{1$ys`GeSzYQ3v8P61)Q5TTrHRbIA$!1fC;&hDra6p{PQ)h^`!8i z;AV+CbB42*=^A%2!##|^oh1aa*jDm61O&0Tr-)&gXgR%jyAC;idVV8g#r4DSg59d@ zxMP~jl;;X`5-(<$s*ABGIpH(?vpm z!=#66+RFU@A4^K(9VR$6_*IzrlDNqb#}AlOVF>ltufn4|!Ec2Ky|u!gx&;%P(?gO! z?!Ab12uOc?e1NFLatf>}ZLAJ1(#>W!56lPNlaXi(4l{N?BB5HbV2#jd_H$`4P(i5n#yr)A1pW zeTurHfTLu>It6pN~zV?br+ zDdO%X_1bRT>{2qJo=bofuqtBI^THFrBJv3Ud~PI+`#e8z%>dC|LLl!cUV6t|>!a*o zt-CZYapI=&101rK9JmC%6v1+Z-21jW(D{p>fhO1hX9Et8l7B52 zB$}U#l0*McN*54X?lXnz)iHQm%*$fwNXymQKGUG`V2g2z!dO}pd6Lq%EwC~ZpUSc9 zjrYF1UBS*6 z_;Zj6a!f{rkSj7f725Py@iag#F%xi4g(_Zq$ms!@!>(ez;!HgFsNW==!sqE~@a$#yMr72L;CoOlm zz23xnVfm1ZwQBA=GN?##2~X?Y(VD26V(u4eAE{UI2(sgclNFXoAtK0)v{cLM)zVO} zh%V00dDewWl_i{;i|Kou&%veP=dvWRz|3-rtWPZc5GmOKOkKO!2c2zScilBhEW(wb zH-N8>@FIea)od|ngTqx34@5Wzrm+_?d&biN@q&g8;)6;xd_IYvHEJE9ep0^G=1|?l zbx#5}9E`2f?*wipG!;)lP%p!t^HZG?u+clAEZP!CobbtwL7O#K|3bV;_7YnfICkhr zX|n-~Or-`FEaC?6ZIeGyVIHl^@us3UdAY=Va%&%DpI{?<+^)okHglXw2b>x*zLn5- zB1zLsULD%M5KKpcBDy%jr>S?ZD4PYsxVQ(fQq<9_{1GDF7uon+(XBo0T@t77-PIEP z9wWYagL|Ozxk{Ew+0O#D%zdTy zXXoUH35Tk5QDZ*G3D14=3Mb1ynbu;7Dsw4I#CIs4JbuJK-}296{&|8wPw*AmCr@hp QQ#V0kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;12 285044 changes to%: (FNS MAKEFILE1 COMPILE-FILE?) previous date%: "10-Aug-2020 21:24:58" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;11) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020 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 FILEPKGCOMS) (RPAQQ FILEPKGCOMS [(COMS (* ;  "standard records for accessing file package type/command parts. Exported for PRETTY") (VARS FILEPKGTYPEPROPS) (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS))) (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS) (INITRECORDS * FILEPKGRECORDS)) [DECLARE%: EVAL@COMPILE DOCOPY (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.") (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG)) (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS] (INITVARS (MSDATABASELST)) [COMS (* ;; "making, adding, listing, compiling files") (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE ADDFILE0 LISTFILES) (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE) (FILELST) (LOADEDFILELST) (NOTLISTEDFILES) (NOTCOMPILEDFILES) (MAKEFILEFORMS) (NILCOMS)) (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% F ST STF (REC . RC) (BREC . RC) (TC . C) (BC . C) (TCOMPL . C) (BCOMPL . C))) (INITVARS (MAKEFILEREMAKEFLG T) (CLEANUPOPTIONS '(RC] (COMS (* ;; "scanning file coms") (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE INFILEPAIRS INFILECOMSMACRO)) (COMS (* ;; "adding to a file") (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM) (INITVARS (DEFAULTCOMHASFILEFLG)) (ADDVARS (MARKASCHANGEDFNS)) (FNS MERGEINSERT MERGEINSERT1) (* ;; "RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file") (VARS [ADDTOFILEKEYLST `(("[" "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" NOECHOFLG T) (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T) (,(CHARACTER (CHARCODE LF)) "" EXPLAINSTRING "{line-feed} - same as previous response" NOECHOFLG T) (" " ,(CONCATCODES (LIST (CHARCODE SPACE) (CHARCODE EOL))) EXPLAINSTRING "{space} - no action" NOECHOFLG T) ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL))) EXPLAINSTRING ,(CONCAT "] - nowhere, item is marked as a dummy" (CHARACTER (CHARCODE EOL))) NOECHOFLG T) ["(" "List: (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE)) ,(CHARACTER (CHARCODE EOL] RETURN (CDR ANSWER] (@ "Near: " EXPLAINSTRING "@ other-item -- put the item near the other item" NOECHOFLG T KEYLST (( "" CONFIRMFLG [,(CHARACTER (CHARCODE EOL] RETURN ANSWER))) [,(CHARACTER (CHARCODE CR)) "" RETURN ,(CHARACTER (CHARCODE SPACE] ("" "File name: " EXPLAINSTRING "a file name" KEYLST (] (LASTFILE))) (COMS (* ;; "deleting an item from a file") (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE) (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T) (MOVD? 'MOVETOFILE 'MOVEITEM NIL T)) (ADDVARS (SYSPROPS PROPTYPE VARTYPE))) [COMS (* ;  "functions for doing things and marking them changed and auxiliary functions") (FNS SAVEPUT) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT) (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT] (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS) (ADDVARS (LISPXFNS (PUT . SAVEPUT) (PUTPROP . SAVEPUT] (COMS (* ;  "sub-functions for file package commands & types") (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED) (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO) (SYSPROPS PROPTYPE)) (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT FILETYPE) (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS PRETTYPRINTYPEMACROS USERMACROS)) (COMS (* ;  "Define the commands below AFTER the various properties have been established.") (USERMACROS M)) (COMS (* ; "GETDEF methods") (FNS RENAME CHANGECALLERS) (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF) (INITVARS (WHEREIS.HASH))) (* ; "Must come after PUTDEF") (FNS FIXEDITDATE EDITDATE?) (* ;  "Edit date support for all kinds of definers (from PARC 6/10/92)") [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES)) (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES] (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS) (COMS (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.") (FNS FILEPKGCOM FILEPKGTYPE) (PROP ARGNAMES FILEPKGCOM) (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS) (FILEPKGTYPES FILEPKGCOMS)) (FILEPKGCOMS FILEPKGCOMS) (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS)) (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS) (VARIABLES VARS CONSTANTS))) (INITVARS (SAVEDDEFS)) (COMS (* ; "EDITCALLERS") (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN) (FNS SEPRCASE) [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL] (INITVARS (SEPRCASEARRAYS) (CLISPCASEARRAYS)) (P (MOVD? 'INFILEP 'FINDFILE) (* ; "or else from SPELLFILE")) (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG) (NOLINKFNS LOADFROM))) (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)) (COMS (* ; "EXPORT") (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS) (FILEPKGCOMS EXPORT) [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")") (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"] (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)) (COMS (* ; "for GAINSPACE") (FNS CLEARFILEPKG) [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE) ((Y "es") (N "o") (E . "verything") (F "ilemaps only "] (GLOBALVARS SMASHPROPSLST1)) (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS) (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T) (SPECVARS COMSNAME)) (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM (NOLINKFNS . T) (SPECVARS COMSNAME) (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1)) (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG) INFILECOMSPROP) (NIL MAKEFILE (LOCALVARS . T) (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES)) (ADDFILE ADDFILE ADDFILE0) (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T)) (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS) (LOCALVARS . T)) (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T)) (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE GETDEFSAVED (RETFNS GETDEFCOM) (NOLINKFNS . T) (GLOBALVARS NOT-FOUNDTAG))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS PRETTYDEFMACROS) (NLAML) (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES]) (* ; "standard records for accessing file package type/command parts. Exported for PRETTY") (RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED HASDEF EDITDEF CANFILEDEF FILEGETDEF)) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP)) (DECLARE%: EVAL@COMPILE (ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE)) (T (/REMPROP DATUM 'ADDTOPRETTYCOM] [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE)) (T (/REMPROP DATUM 'DELFROMPRETTYCOM] [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE)) (T (/REMPROP DATUM 'PRETTYTYPE] [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE)) (T (/REMPROP DATUM 'FILEPKGCONTENTS] (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS] (STANDARD [COND [NEWVALUE (PUTASSOC DATUM NEWVALUE (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS)) (SETTOPVAL 'PRETTYDEFMACROS (LIST (LIST DATUM] (T (SETTOPVAL 'PRETTYDEFMACROS (REMOVE (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS)) (GETTOPVAL 'PRETTYDEFMACROS] UNDOABLE (COND [NEWVALUE (/PUTASSOC DATUM NEWVALUE (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS)) (/SETTOPVAL 'PRETTYDEFMACROS (LIST (LIST DATUM] (T (/SETTOPVAL 'PRETTYDEFMACROS (REMOVE (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS)) (GETTOPVAL 'PRETTYDEFMACROS] (* Not an atom record cause want  REMPROP on NILs.) (* NOTE%: PRETTCOM on PRETTY has  open-coded access to the MACRO  property.) (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS))) (ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED HASDEF EDITDEF FILEGETDEF CANFILEDEF) (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM)) (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE)) ) (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST DATUM))) (STANDARD (SETTOPVAL (CAR ( SEARCHPRETTYTYPELST DATUM NEWVALUE) ) NEWVALUE) UNDOABLE (/SETTOPVAL (CAR ( SEARCHPRETTYTYPELST DATUM NEWVALUE)) NEWVALUE))) (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST DATUM))) (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST DATUM NEWVALUE)) NEWVALUE))) (ALLFIELDS NIL (/SETTOPVAL 'PRETTYTYPELST (REMOVE (SEARCHPRETTYTYPELST DATUM) (GETTOPVAL 'PRETTYTYPELST] (* NOTE%: PRETTYCOM on PRETTY has  open-coded access to GETDEF property) (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS)) (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X) (PUT X 'PROPTYPE 'FILEPKGCOMS] (ADDTOVAR PRETTYTYPELST )))) (ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP) [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE) (STANDARD (PUTPROP DATUM 'FILE NEWVALUE) UNDOABLE (/PUTPROP DATUM 'FILE NEWVALUE]) (RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME)) (RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED)) ) (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS) [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS)) (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X) (PUT X 'PROPTYPE 'FILEPKGCOMS] (ADDTOVAR PRETTYTYPELST ) ) (* "END EXPORTED DEFINITIONS") (DEFINEQ (SEARCHPRETTYTYPELST [LAMBDA (TYPE FLG) (* rmk%: " 3-JAN-82 22:55") (* ;  "access functions used by the records") (AND (LITATOM TYPE) (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X) TYPE)) (COND (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE 'LST) TYPE NIL)) (GETTOPVAL 'PRETTYTYPELST] (OR (LISTP (GETTOPVAL (CAR FLG))) (/SETTOPVAL (CAR FLG) NIL)) FLG]) (PRETTYDEFMACROS [NLAMBDA ARGS (* lmm " 5-SEP-78 16:16") (* ;  "included so that old files will continue to load") (for X in ARGS collect (FILEPKGCOM (CAR X) 'MACRO (CDR X]) (FILEPKGCOMPROPS [NLAMBDA PROPS (MAPC PROPS (FUNCTION (LAMBDA (Y) (OR (MEMB Y SYSPROPS) (SETQ SYSPROPS (CONS Y SYSPROPS))) (PUT Y 'PROPTYPE 'FILEPKGCOMS]) ) (RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP)) (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS) [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS)) (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X) (PUT X 'PROPTYPE 'FILEPKGCOMS] (ADDTOVAR PRETTYTYPELST ) (DECLARE%: EVAL@COMPILE DOCOPY (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG)) (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS)) ) (RPAQ? MSDATABASELST ) (* ;; "making, adding, listing, compiling files") (DEFINEQ (CLEANUP [NLAMBDA FILES (* lmm "14-Aug-84 19:17") (PROG (TEM1 TEM2 OPTIONS) (COND ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES] (SETQ OPTIONS (CAR FILES)) (SETQ FILES (CDR FILES))) (T (SETQ OPTIONS CLEANUPOPTIONS))) (RETURN (APPEND (MAKEFILES OPTIONS FILES) (COND ((NOT (MEMB 'LIST OPTIONS)) NIL) ((NULL FILES) (LISTFILES)) ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES)) (* ;  "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.") (APPLY 'LISTFILES TEM1))) (COND [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS] ((NULL FILES) (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES) (CDR TEM1)) TEM2) ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES)) (COMPILEFILES0 TEM2 (CDR TEM1)) TEM2]) (COMPILEFILES [NLAMBDA FILES (* lmm "14-Aug-84 19:17") (COND ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES] (COMPILEFILES0 (CDR FILES) (CAR FILES))) (T (COMPILEFILES0 FILES]) (COMPILEFILES0 [LAMBDA (FILES OPTIONS) (* rmk%: "19-FEB-83 21:59") (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES) first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS)) (C (SETQ RCFLG NIL) (CDR OPTIONS)) (RC (CDR OPTIONS)) OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X) 70 FILELST NIL X) (CAR X)) RCFLG OPTS X]) (CONTINUEDIT [LAMBDA (FILE) (* bvm%: "30-Aug-86 15:09") (PROG (STREAM FL TEM FC ENV) (RESETLST [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT] (SETQ FILE (FULLNAME STREAM)) (SETFILEPTR STREAM 0) (CL:MULTIPLE-VALUE-SETQ (ENV FC) (\PARSE-FILE-HEADER STREAM 'RETURN))) (COND ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE] (LOADFROM FILE) (* ;  "also calls addfile to notice the file.") )) (/replace FILECHANGES of FL with (FILECHANGES FC)) [/replace FILEDATES of FL with (LIST (create FILEDATEPAIR FILEDATE _ (CADR FC) DATEFILENAME _ FILE) (create FILEDATEPAIR FILEDATE _ [CAR (SETQ TEM (CDR (MEMB 'date%: FC] DATEFILENAME _ (CADR TEM] (RETURN FILE]) (MAKEFILE [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE) (* ; "Edited 29-Aug-89 11:46 by bvm") (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL; LIST means list the FILE; RC means RECOMPILE, C means COMPILEL; --- for C AND RC assume ST unless next option is F.") (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS] PRETTYFLG)) (*PRINT-BASE* (if (EQ *PRINT-BASE* 8) then 8 else (* ; "make sure radix is either 8 or 10, because all others don't read in like they print. Maybe obsolete now with makefile environments") 10)) FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE))) (DECLARE (CL:SPECIAL PRETTYFLG)) (SETQ FILE (CAR Z)) (* ;  "Necessary because FILE might have been misspelled.") (SETQ ROOTNAME (CADR Z)) (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.") (SETQ FILEPROP (CDDR Z)) (UPDATEFILES) (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.") (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP)) (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME))) (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE)) LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP)) (NULL FILEDATES)) then (* ;  "File has never been loaded and never dumped i.e. user just set up COMS in core") elseif [OR (EQMEMB 'NEW OPTIONS) (AND (NULL MAKEFILEREMAKEFLG) (NOT (MEMB 'REMAKE OPTIONS] then (COND ((AND (fetch LOADTYPE of FILEPROP) (NEQ T (fetch LOADTYPE of FILEPROP))) (LISPXPRIN2 FILE T T) (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP) (LOADCOMP "the file was loaded for compilation purposes only") ((compiled Compiled COMPILED) " -- only the compiled file has been loaded ") ((loadfns LOADFNS) " -- only some of its symbolics have been loaded ") (SHOULDNT)) T) (COND ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ") 'Y) (* ;  "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.") (GO OUT))) (/replace LOADTYPE of FILEPROP with NIL))) (SETQ SOURCEFILE NIL) (SETQ REPRINTFNS NIL) elseif SOURCEFILE then (* ; "source file given") elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T)) (EQUAL (FILEDATE SOURCEFILE) (fetch FILEDATE of (CAR FILEDATES] (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE (fetch DATEFILENAME of (CAR FILEDATES ] (INFILEP SOURCEFILE) (EQUAL (FILEDATE SOURCEFILE) (fetch FILEDATE of (CAR FILEDATES] then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE) (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))) elseif [AND (CDR FILEDATES) [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES] (EQUAL (FILEDATE SOURCEFILE) (fetch FILEDATE of (CADR FILEDATES] then (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.") (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP) (fetch FILECHANGES of ROOTNAME))) (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)) else (LISPXPRIN1 '"can't find either the previous version or the original version of " T) (LISPXPRIN2 FILE T T) (LISPXPRIN1 '", so it will have to be written anew " T) (SETQ SOURCEFILE NIL) (SETQ REPRINTFNS NIL) (push OPTIONS 'NEW) (SETQ CHANGES (fetch FILECHANGES of ROOTNAME)) (GO LP0)) (COND ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP) (LOADCOMP (* ;  "only loaded via LOADCOMP. Need to do LOADFROM") (LIST 'N SOURCEFILE "was loaded with LOADCOMP" '- "LOADFROM it to obtain VARS/COMS")) (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%: (fetch COMSNAME of FILEPROP)) (LIST 'Y "only compiled version of" ROOTNAME "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions" ))) ((compiled loadfns) (LIST 'N "Only some functions from" SOURCEFILE "loaded via LOADFNS. Load all other expressions from it" )) NIL))) (SELECTQ [ASKUSER DWIMWAIT (CAR Z) (CDR Z) '((Y "es ") (N "o ") (A "bort MAKEFILE "] (Y (SELECTQ (fetch LOADTYPE of FILEPROP) (LOADCOMP (* ;  "file was never actually loaded, just loadcomped. thus no filecoms") (LOADFROM SOURCEFILE)) (Compiled (* ;; "This is going to be a remake. If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.") (LOADVARS 'DONTCOPY SOURCEFILE) (/replace LOADTYPE of FILEPROP with 'COMPILED) (* ; "So wont have to be done again.") (* ;; "These are the only DECLARE:'s that are not also on the compiled file. Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE: Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)") ) ((loadfns compiled) (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.") (LOADVARS T SOURCEFILE)) NIL)) (A (GO OUT)) NIL))) (RESETLST [COND ((MEMB 'NOCLISP OPTIONS) (RESETSAVE PRETTYTRANFLG T)) ((MEMB 'CLISP% OPTIONS) (RESETSAVE PRETTYTRANFLG 'BOTH] (RESETSAVE %#UNDOSAVES) [COND ((OR (MEMB 'CLISPIFY OPTIONS) (MEMB 'CLISP OPTIONS)) (RESETSAVE CLISPIFYPRETTYFLG T)) ((OR (EQ FILETYPE 'CLISP) (MEMB 'CLISP (LISTP FILETYPE))) (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES] (for X in MAKEFILEFORMS do (ERSETQ (EVAL X))) (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP) REPRINTFNS SOURCEFILE CHANGES))) (SETQ LASTFILE ROOTNAME) (/replace TOBEDUMPED of FILEPROP with NIL) (COND ((NOT (EQMEMB 'DON'TLIST FILETYPE)) (pushnew NOTLISTEDFILES ROOTNAME))) (COND ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE)) (pushnew NOTCOMPILEDFILES ROOTNAME))) [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL)) (SELECTQ OPT (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES) (MAKEFILE1 FILE T (CDR TAIL)))) (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES) (MAKEFILE1 FILE NIL (CDR TAIL)))) (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES) (APPLY 'LISTFILES (LIST FILE)))) (COND ((MEMB OPT MAKEFILEOPTIONS)) ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL OPTIONS) (GO $$LP)) (T (ERROR "Unrecognized MAKEFILE option" OPT] (RETURN FILE) OUT (RETURN (LIST FILE "-- MAKEFILE not performed."]) (FILECHANGES [LAMBDA (FILE TYPE) (* bvm%: "30-Aug-86 15:08") (* ;; "If FILE is a list, it is assumed to be a file-created expressions; otherwise, the filecreated expression is read from FILE. If TYPE, returns the list of changed items of that type from the changes expression. If TYPE=NIL, returns the whole list of typed change-lists") (PROG ([FCEXPR (OR (LISTP FILE) (AND FILE (RESETLST (LET (OLDPTR STREAM) [if (SETQ STREAM (OPENP FILE 'INPUT)) then (SETQ OLDPTR (GETFILEPTR STREAM)) (SETFILEPTR STREAM 0) else (RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT] (CL:MULTIPLE-VALUE-BIND (ENV FC) (\PARSE-FILE-HEADER STREAM 'RETURN) (if OLDPTR then (SETFILEPTR STREAM OLDPTR)) FC)))] FNS CHANGES) (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR))) (MEMB 'previous CHANGES))) [if (AND TYPE (NEQ TYPE 'FNS)) then (RETURN (CDR (ASSOC TYPE CHANGES] (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM))) (* ;  "Old style changes expression listed FNS by name and other things by type") (RETURN (if TYPE then (* ; "TYPE=FNS cause of test above.") (NCONC FNS (CDR (ASSOC 'FNS CHANGES))) elseif FNS then (CONS (CONS 'FNS FNS) (SUBSET CHANGES (FUNCTION LISTP))) else CHANGES]) (FILEPKG.MERGECHANGES [LAMBDA (C1 C2) (* rmk%: "24-MAY-82 23:09") (* ;; "Merges 2 changes lists into a single one. Treat LITATOM's as FNS, to accomodate old-style format on files.") (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND E1))) in C2 do [COND ((SETQ TEMP (ASSOC (CAR E2) VAL)) (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP)) collect X))) (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL]) (FILEPKG.CHANGEDFNS [LAMBDA (CHANGES) (* rmk%: "20-MAY-82 22:00") (* ;; "Returns list of function names from a file-changes list. Interprets old format (functions are atoms) and new format (with explicit type headers)") (CDR (ASSOC 'FNS CHANGES]) (MAKEFILE1 [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES) (* ; "Edited 27-Oct-2020 15:40 by rmk:") (* ; "Edited 29-Aug-89 11:46 by bvm") (* ;; "RMK: Call COMPILE-FILE? with FILE instead of (ROOTFILENAME FILE)") (PROG ((ROOTNAME (ROOTFILENAME FILE)) (COMPILER (COMPILE-FILE? FILE)) GROUP) (COND ((AND (OR (EQ COMPILER 'BCOMPL) (EQ COMPILER 'TCOMPL)) (NOT (FILEFNSLST ROOTNAME))) (* ;  "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.") (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES)) (RETURN NIL))) (COND ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP)) suchthat (AND (NEQ X ROOTNAME) (OR (fetch TOBEDUMPED of (fetch FILEPROP of X)) (MEMB X OTHERFILES] (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled. Wait.") (RETURN))) (LISPXPRIN1 '" compiling " T) (LISPXPRINT (OR GROUP FILE) T T) (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS) 'ST) (EQ (CAR OPTIONS) 'STF] (FORGET-EXPRS? (EQ (CAR OPTIONS) 'STF] (SELECTQ COMPILER ((FAKE-COMPILE-FILE) (* ;  "The old CommonLispy interface to the ByteCompiler.") (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS (AND REDEFINE? (NOT FORGET-EXPRS?)))) ((CL:COMPILE-FILE) (* ; "The new, improved (?) compiler") (CL:COMPILE-FILE FILE :LOAD (COND ((AND REDEFINE? (NOT FORGET-EXPRS? )) :SAVE) (REDEFINE? T) (T NIL)))) ((TCOMPL BCOMPL) (* ; "The old ByteCompiler") [IF (MEMB (CAR OPTIONS) '(ST F S STF)) THEN (LISPXUNREAD (LIST (CAR OPTIONS] [IF GROUP THEN (* ;;  "File contained in FILEGROUP. Therefore must be blockcompiled.") (IF RECOMPFLG THEN (BRECOMPILE GROUP) ELSE (BCOMPL GROUP)) ELSEIF (EQ COMPILER 'TCOMPL) THEN (IF RECOMPFLG THEN (RECOMPILE FILE) ELSE (TCOMPL (LIST FILE))) ELSE (IF RECOMPFLG THEN (BRECOMPILE FILE) ELSE (BCOMPL (LIST FILE]) (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?..."))) T T]) (COMPILE-FILE? [LAMBDA (FILE) (* ; "Edited 27-Oct-2020 15:39 by rmk:") (* ; "Edited 19-Jan-87 21:12 by Pavel") (* ;; "RMK: Argument is FILE instead of ROOTFILENAME, maybe more information") (* ;;; "Which compiler should CLEANUP use?") (LET ((TYPE (GET (ROOTFILENAME FILE) 'FILETYPE)) (UNKNOWN NIL)) (FOR X INSIDE TYPE DO (SELECTQ X ((TCOMPL :TCOMPL) (RETURN 'TCOMPL)) ((BCOMPL :BCOMPL) (RETURN 'BCOMPL)) ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) (RETURN 'FAKE-COMPILE-FILE)) ((:COMPILE-FILE :XCL-COMPILE-FILE) (RETURN 'CL:COMPILE-FILE)) ((CLISP) NIL) (SETQ UNKNOWN T)) FINALLY (IF UNKNOWN THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE )) (RETURN *DEFAULT-CLEANUP-COMPILER*]) (MAKEFILES [LAMBDA (OPTIONS FILES) (* rmk%: "23-FEB-83 21:20") (RESETVARS (%#UNDOSAVES) (* ;  "Willing to save arbitrary amounts of undo info") (UPDATEFILES) [COND ((NULL FILES) (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE (COND ((NULL FLG) (* ; "Gets printed the first time") ' "****NOTE: the following are not contained on any file: ") (T '" "] do (SETQ FLG T) finally (AND FLG (ADDTOFILES?] (SETQ OPTIONS (MKLIST OPTIONS)) (RETURN (for FILE inside (OR FILES FILELST) when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP of (ROOTFILENAME FILE] collect (LISPXPRIN2 FILE T T) (LISPXPRIN1 '|...| T) (PROG1 (MAKEFILE FILE OPTIONS) (LISPXTERPRI T]) (ADDFILE [LAMBDA (FILE LOADTYPE PRLST FCLST) (* bvm%: "29-Aug-86 12:22") (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.") (PROG ((ROOTNAME (ROOTFILENAME FILE)) FLST VAL) [COND ((NOT FCLST) (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE))) [(NULL (CDR FCLST)) (* ; "A simple symbolic file") (SETQ FCLST (CAR FCLST)) (SETQ VAL (ADDFILE0 (COND ((LITATOM (CADR FCLST)) (ROOTFILENAME (CADR FCLST))) (T ROOTNAME)) LOADTYPE FILE (CAR FCLST] (T (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.") (SELECTQ LOADTYPE ((T LOADFNS) (SETQ LOADTYPE 'Compiled)) (loadfns (SETQ LOADTYPE 'compiled)) (LOADCOMP (* ;  "loadcomp on compiled file. Don't notice since we don't know what its state is") NIL) (SHOULDNT)) (for X in (CDR FCLST) when (LITATOM (CADR X)) do (push FLST (CADR X)) (OR (EQ LOADTYPE 'LOADCOMP) (ADDFILE0 (ROOTFILENAME (CADR X)) LOADTYPE (CADR X) (CAR X] (UPDATEFILES PRLST (OR FLST (LIST FILE))) [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES when (AND (LITATOM TYPE) (SETQ CHANGED (fetch CHANGED of TYPE))) do (/replace CHANGED of TYPE with (INTERSECTION (CDR (ASSOC TYPE PRLST)) CHANGED] (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS)) (RETURN VAL]) (ADDFILE0 [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT) (* lmm "28-Nov-84 16:47") (PROG (COMS X FILEPROP FLG TEM) TOP (SETQ COMS (FILECOMS ROOTNAME)) [COND ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME)) (COND ([AND LOADTYPE (FMEMB LOADTYPE (CDR (FMEMB (fetch LOADTYPE of FILEPROP) '(LOADCOMP loadfns compiled Compiled LOADFNS COMPILED NIL T] (/replace LOADTYPE of FILEPROP with LOADTYPE) (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property. 'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file. 'Compiled' means all but DECLARE: expressions are in. e.g. user does LOAD of a compiled file. COMPILED means everything is in, e.g. user does LOADDFROM a compiled file. LOADFNS means everything in, e.g. user des LOADFROM symbolic file. COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted. NIL is a makefile when coms were set up in core. T is full load of symbolic file. The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.") (* ;; "LOADCOMP means file was loadcomp'ed. note that the actual structure is a tree, not a list, and the above is only an approximation. if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc. however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.") (GO OUT)) (T (GO OUT1] (COND [(OR LOADTYPE (LISTP (GETTOPVAL COMS))) (SETQ FILEPROP (/replace FILEPROP of ROOTNAME with (create FILEPROP COMSNAME _ COMS LOADTYPE _ LOADTYPE] (FLG (GO ERROR)) ((AND DWIMFLG (EQ ROOTNAME FULLNAME) (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T))) (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.") (SETQ FULLNAME ROOTNAME) (SETQ FLG T) (* ;  "so wont try to spelling correct again if file isnt there") (GO TOP)) (T (GO ERROR))) OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME with (LIST (create FILEDATEPAIR FILEDATE _ DAT DATEFILENAME _ FULLNAME] (AND (EQ LOADTYPE T) (/replace TOBEDUMPED of FILEPROP with NIL)) OUT1 [COND ([AND (LISTP (GETTOPVAL COMS)) (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ;  "coms wuld not be set up on a loadccomp.") (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST] (RETURN (COND ((NULL LOADTYPE) (* ; "call from makefile.") (CONS FULLNAME (CONS ROOTNAME FILEPROP))) (T FILEPROP))) ERROR (ERROR FULLNAME "not file name." T]) (LISTFILES [NLAMBDA FILES (* rmk%: " 3-Dec-84 08:58") (DECLARE (GLOBALVARS NOTLISTEDFILES)) (* ; "LISTFILES1 is machinedependent") (for FILE FULLNAME OPTIONS in (COND (FILES (SETQ FILES (NLAMBDA.ARGS FILES))) (T NOTLISTEDFILES)) when (COND ((LISTP FILE) (SETQ OPTIONS (APPEND FILE OPTIONS)) NIL) ((SETQ FULLNAME (FINDFILE FILE)) FULLNAME) (T (printout T FILE " not found." T) NIL)) collect [COND ((LISTFILES1 FULLNAME OPTIONS) (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T) NOTLISTEDFILES] FULLNAME]) ) (RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE) (RPAQ? FILELST ) (RPAQ? LOADEDFILELST ) (RPAQ? NOTLISTEDFILES ) (RPAQ? NOTCOMPILEDFILES ) (RPAQ? MAKEFILEFORMS ) (RPAQ? NILCOMS ) (ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% F ST STF (REC . RC) (BREC . RC) (TC . C) (BC . C) (TCOMPL . C) (BCOMPL . C)) (RPAQ? MAKEFILEREMAKEFLG T) (RPAQ? CLEANUPOPTIONS '(RC)) (* ;; "scanning file coms") (DEFINEQ (FILEPKGCHANGES [LAMBDA N (* Pavel " 7-Oct-86 19:22") (COND [(EQ N 0) (PROG (TEM) (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X) (SETQ TEM (FILEPKGCHANGES X))) collect (CONS X TEM] [(EQ (ARG N 1) T) (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES X] [(EQ N 1) (COND [(LISTP (ARG N 1)) (for X in (ARG N 1) when (FMEMB (CAR X) FILEPKGTYPES) do (/replace CHANGED of (CAR X) with (CDR X] (T (for Y on (fetch CHANGED of (ARG N 1)) when [AND (CAR Y) (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y) Z] collect (CAR Y] (T (/replace CHANGED of (ARG N 1) with (ARG N 2]) (GETFILEPKGTYPE [LAMBDA (TYPE ONLY NOERROR NAME) (* lmm "20-Nov-86 23:10") (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ") (COND [(LISTP TYPE) (* ;; " given a list of types, coerce them all or return NIL") (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME) (RETURN] ((EQ TYPE '?) (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ") (AND NAME (TYPESOF NAME))) [(AND (NEQ ONLY 'COMS) (OR (SELECTQ TYPE (NIL 'FNS) (T 'VARS) NIL) (for X in FILEPKGTYPES do (if (EQ TYPE X) then (* ;; "type matched exactly") (RETURN TYPE) elseif (AND (LISTP X) (EQ TYPE (CAR X))) then (RETURN (CDR X] [(AND (NEQ ONLY 'TYPE) (LITATOM TYPE) (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST)) (* ; "Prefer an exact match quickly") ] [(AND (NEQ ONLY 'COMS) (LITATOM TYPE) (for X in FILEPKGTYPES bind NAME do (SETQ NAME (if (NLISTP X) then X else (CAR X))) (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization") (AND (<= 0 (- (NCHARS NAME) (NCHARS TYPE)) 1) (STRPOS TYPE NAME) (RETURN (if (EQ X NAME) then X else (CDR X] [(FIXSPELL TYPE NIL (SELECTQ ONLY (TYPE FILEPKGTYPES) (COMS FILEPKGCOMSPLST) (UNION FILEPKGTYPES FILEPKGCOMSPLST] ((NOT NOERROR) (ERROR (SELECTQ ONLY (TYPE "unrecognized manager definition type") (COMS "unrecognized manager command") "unrecognized manager definition-type/command") TYPE]) (MARKASCHANGED [LAMBDA (NAME TYPE REASON) (* ; "Edited 25-May-88 15:37 by drc:") (COND (FILEPKGFLG (SETQ REASON (SELECTQ REASON ((CLISP LOAD CHANGED DEFINED DELETED) REASON) (NIL 'CHANGED) (T 'DEFINED) (ERROR "bad REASON in MARKASCHANGED" REASON))) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (for FN inside (fetch WHENCHANGED of TYPE) do (APPLY* FN NAME TYPE REASON)) (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON)) [COND ((EQ REASON 'DELETED) (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L) NAME) do (/RPLACA L NIL)) (* ;  "unmark as changed and remove from files") (DELFROMFILES NAME TYPE)) (T (LET ((LST (push (fetch CHANGED of TYPE) NAME))) (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST) LISPXHIST)) (* ;  "UNDO by smashing with NIL; makes calls to MARKASCHANGED independent") ] NAME]) (FILECOMS [LAMBDA (FILE X) (* rmk%: "19-FEB-83 13:55") (COND ((AND (NULL FILE) (NULL X)) 'NILCOMS) [(AND (OR (NULL X) (EQ X 'COMS)) (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE] (T (PACK* (NAMEFIELD FILE) (OR X 'COMS]) (WHEREIS [LAMBDA (NAME TYPE FILES FN) (* ; "Edited 12-Jul-88 17:14 by MASINTER") (* ;; "T as a NAME has a special meaning to INFILECOMS? so don't pass through.") (CL:UNLESS (EQ NAME T) (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES) FILELST) (FUNCTION (LAMBDA (FILE) (INFILECOMS? NAME TYPE (FILECOMS FILE] (AND (EQ FILES T) (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS) (LET ((FILES NIL)) (for TY inside TYPE do (for FILE-NAME in (XCL::HASH-FILE-WHERE-IS NAME (GETFILEPKGTYPE TYPE)) do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME)) FILES))) (REVERSE FILES] (CL:IF FN [MAPC IN-FILES (FUNCTION (LAMBDA (FILE) (APPLY* FN NAME FILE] IN-FILES)))]) (SMASHFILECOMS [LAMBDA (FILE) (* rmk%: "19-FEB-83 22:15") (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X) do (SETTOPVAL X 'NOBIND)) FILE]) (FILEFNSLST [LAMBDA (FILE) (* ; "Edited 14-Jun-90 19:30 by jds") (FILECOMSLST FILE '(FUNCTIONS FNS]) (FILECOMSLST [LAMBDA (FILE TYPE FLG) (* JonL "24-Jul-84 19:48") (* ;  "TYPE is coerced in the innards of INFILECOMS?") (COND ((EQ FLG 'UPDATE) (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE) FLG))) (T (INFILECOMS? NIL TYPE (FILECOMS FILE) FLG]) (UPDATEFILES [LAMBDA (PRLST FLST) (* rmk%: "19-FEB-83 14:27") (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g. LOAD, LOADFNS) involving the files in FLST began.") (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE)) do (COND ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE))) (* ;  "FILEPKGCHANGES eliminates duplicates") (/replace CHANGED of TYPE with NIL)) (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) (* ;; "First check NIL=Nowhere. LST:1 contains variables whose values are on the file literally. These are `found' but not marked. LST::1 contains all other items.") (SETQ FOUND (NCONC (CAR LST) (CDR LST) FOUND)) do (SETQ PCHANGES (COND ((FMEMB (fetch DATEFILENAME of (CAR (fetch FILEDATES of FILE))) FLST) (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began. Thus, by this intersection we only worry about items that were previously changed; any items that were only changed during this operation are ignored.") (INTERSECTION CHANGED PREVITEMS)) (T CHANGED))) [COND ([AND PCHANGES [SETQ COMS (fetch COMSNAME of (SETQ FILEPROP (LISTP (fetch FILEPROP of FILE] (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE] (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms") [COND ((CDR LST) (* ; "CDR items must be distributed") [COND ((NULL (fetch TOBEDUMPED of FILEPROP)) (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL") [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL 'NOTLISTEDFILES] (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE (GETTOPVAL ' NOTCOMPILEDFILES ] (* ;  "Get the (possibly new) TYPE item list to smash") [COND [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED of FILEPROP] (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE] (* ;  "Now distribute items to the file property") (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP) ) do (/NCONC1 TYPEDPROP Y] (SETQ FOUND (NCONC (CAR LST) (CDR LST) FOUND] finally (/replace CHANGED of TYPE with (LDIFFERENCE CHANGED FOUND]) (INFILECOMS? [LAMBDA (NAME TYPE COMS ONFILETYPE) (* ; "Edited 12-Jul-88 17:42 by MASINTER") (* ;; "Returns T if NAME is 'CONTAINED' in COMS. If NAME is NIL, then value is a list of all of the functions contained in COMS. If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.) Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1. while elements are the subset of NAME which are on the file in other case") (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS? returns the dotted pair of (literals . elements) where literals are those which are `literally' on the file (e.g. (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned") (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ") (PROG (VAL LITERALS ORIGFLG) (SETQ TYPE (GETFILEPKGTYPE TYPE)) (SELECTQ ONFILETYPE (EDIT (SELECTQ TYPE (FILEVARS (RETURN)) NIL)) NIL) [COND ((LITATOM COMS) (SELECTQ TYPE ((VARS FILEVARS) (* ;  "the COMS of a file are also on it") (INFILECOMSVAL COMS)) NIL) (SETQ COMS (EVALV COMS] (INFILECOMS COMS) (SETQ VAL (DREVERSE VAL)) (RETURN (COND ((EQ ONFILETYPE 'UPDATE) (CONS LITERALS VAL)) (T VAL]) (INFILECOMTAIL [LAMBDA (COM FLG) (* ; "Edited 2-Aug-88 02:15 by masinter") [SETQ COM (COND ((EQ (CADR COM) '*) (COND [(LITATOM (CADDR COM)) (LISTP (EVALV (CADDR COM] (T [RESETVARS (DWIMLOADFNSFLG) (NLSETQ (SETQ COM (EVAL (CADDR COM] COM))) (T (CDR COM] (if (NOT FLG) then (for X in COM do [if (AND (LISTP X) (EQ (CAR X) COMMENTFLG)) then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X) (OR (NLISTP X) (NEQ (CAR X) COMMENTFLG] finally (RETURN COM)) else COM]) (INFILECOMS [LAMBDA (COMS) (* rmk%: "19-FEB-83 22:17") (for X in COMS do (INFILECOM X]) (INFILECOM [LAMBDA (COM) (* ; "Edited 2-Aug-88 02:27 by masinter") (COND [(NLISTP COM) (COND ((EQ TYPE 'VARS) (INFILECOMSVAL COM] ((EQ (CAR COM) COMMENTFLG) (* ;; "must be special case'd first so that (* * values) doesn't make it look like `values' is a variable") (* ;  "don't know why I should bother, but someone might want to know all of the comments on a file???") (COND ((EQ TYPE COMMENTFLG) (INFILECOMSVAL COM T))) NIL) (T (PROG ((COMNAME (CAR COM)) (TAIL (CDR COM)) CFN TEM) (COND [[COND ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME)) (SETQ TEM (APPLY* CFN COM (COND ((AND (NULL ONFILETYPE) (NOT (CL:SYMBOLP NAME))) (* ;  "call from WHEREIS of a name which is not a symbol") (LIST NAME)) (T NAME)) TYPE ONFILETYPE))) ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME)) (* ; "for compatability") (SETQ TEM (APPLY* CFN COM TYPE NAME] (COND [(NLISTP TEM) (COND ((EQ TEM T) (COND ((OR (EQ NAME T) (NULL ONFILETYPE)) (RETFROM 'INFILECOMS? T] (T (INFILECOMSVALS TEM] ((LISTP TAIL) (* ;; "this SELECTQ handles the `exceptional cases' for the built in types. There is an explicit RETURN in the SELECTQ clause if the default is handled") (SELECTQ COMNAME ((PROP IFPROP) (SETQ TAIL (CDR TAIL))) NIL) [COND ((EQ (CAR TAIL) '*) (COND ((LITATOM (CADR TAIL)) (SELECTQ TYPE ((VARS FILEVARS) (INFILECOMSVAL (CADR TAIL))) NIL)) ((AND (LISTP (CADR TAIL)) (EQ ONFILETYPE 'UPDATE) (EQ TYPE 'VARS) (EQ (CAADR TAIL) 'PROGN) (FMEMB (CAR (LAST (CADR TAIL))) NAME)) (SETQ VAL (CONS (CADR TAIL) VAL] (SELECTQ COMNAME ((COMS EXPORT) (INFILECOMS (INFILECOMTAIL COM T))) (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM) T))) (DECLARE%: (* ; "skip over DECLARE: tags") [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM)) (IFCDECLARE (INFILECOMTAIL COM) (EQ TYPE 'DECLARE%:]) (ORIGINAL (* ; "dont expand macros") (PROG ((ORIGFLG T)) (INFILECOMS (INFILECOMTAIL COM T)))) ((PROP IFPROP) (* ;  "this currently does not handle `pseudo-types' of PROPNAMES") (SELECTQ TYPE (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM) T) (CADR COM))) (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM)) (CADR COM))) NIL)) (PROPS (RETURN (IFCPROPS COM))) (MACROS (RETURN (SELECTQ TYPE (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T) MACROPROPS)) (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T))) NIL))) (ALISTS (* ;  "sigh. This should probably also `coerce' when asking for LISPXMACROS, etc.") (RETURN (SELECTQ TYPE (ALISTS (INFILEPAIRS (INFILECOMTAIL COM))) NIL))) (P [RETURN (SELECTQ TYPE ((EXPRESSIONS P) (INFILECOMSVALS (INFILECOMTAIL COM T) T)) (COND ((NULL ONFILETYPE) (* ; "for WHEREIS and FILECOMSLST") (SELECTQ TYPE (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR)) (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE)) NIL]) ((ADDVARS APPENDVARS) (SELECTQ TYPE (VARS [RETURN (AND (NULL ONFILETYPE) (for X in (INFILECOMTAIL COM T) do (INFILECOMSVAL (CAR X) T]) (ALISTS [RETURN (for X in (INFILECOMTAIL COM T) when (EQMEMB 'ALIST (GETPROP (CAR X) 'VARTYPE)) do (for Z in (CDR X) do (INFILECOMSVAL (LIST (CAR X) (CAR Z)) T]) (OR (EQ TYPE COMNAME) (RETURN)))) ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) [RETURN (COND ((EQ TYPE 'EXPRESSIONS) (for X in (INFILECOMTAIL COM T) when (AND (LISTP X) (NEQ (CAR X) COMMENTFLG)) do (INFILECOMSVAL (CONS 'SETQ X) T))) ((OR (EQ TYPE 'VARS) (EQ TYPE COMNAME))(* ;  "either want all VARS, or else want all FILEVARS and this is a FILEVARS command") (for X in (INFILECOMTAIL COM T) do (COND ((LISTP X) (AND (CAR X) (NEQ (CAR X) COMMENTFLG) (INFILECOMSVAL (CAR X) T))) (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS]) (DEFS [RETURN (for X in (INFILECOMTAIL COM T) when (EQ TYPE (CAR X)) do (INFILECOMSVALS (CDR X]) (FILES (RETURN)) NIL) (* ;; "Exceptional cases now handled. If TYPE matches (CAR COM) then scan the tail as usual. Else expand the com's MACRO, if it has one, unless there was a CONTENTS function") (COND ((EQ COMNAME TYPE) (INFILECOMSVALS (INFILECOMTAIL COM T))) [(AND (LISTP TYPE) (FMEMB COMNAME TYPE)) (LET ((TYPE COMNAME)) (INFILECOMSVALS (INFILECOMTAIL COM T] ((AND (OR (NULL CFN) (AND (EQ CFN T) (NULL ONFILETYPE))) (NULL ORIGFLG) (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME))) (INFILECOMS (SUBPAIR (CAR TEM) (INFILECOMTAIL COM T) (CDR TEM]) (INFILECOMSVALS [LAMBDA (X FLG) (* ; "Edited 2-Aug-88 02:21 by masinter") (for Y in X when (NOT (AND (LISTP Y) (EQ (CAR Y) COMMENTFLG))) do (INFILECOMSVAL Y FLG]) (INFILECOMSVAL [LAMBDA (X FLG) (* ; "Edited 12-Jul-88 17:56 by MASINTER") (COND [(EQ ONFILETYPE 'UPDATE) (AND (OR (NULL NAME) (MEMBER X NAME)) (COND (FLG (SETQ LITERALS (CONS X LITERALS))) (T (SETQ VAL (CONS X VAL] ((AND (EQ ONFILETYPE 'EDIT) FLG) (* ;  "literals should not be edited as they are on the fileCOMS") NIL) ((EQ ONFILETYPE 'TYPESOF) (AND (COND ((LITATOM NAME) (EQ NAME X)) (T (EQUAL NAME X))) (CL:PUSHNEW TYPE VAL))) ([OR (EQ NAME T) (COND ((LITATOM NAME) (EQ NAME X)) (T (EQUAL NAME X] (RETFROM (FUNCTION INFILECOMS?) T)) ((NULL NAME) (SETQ VAL (CONS X VAL]) (INFILECOMSPROP [LAMBDA (AT PROP) (* lmm "25-SEP-81 17:15") (COND [(EQ ONFILETYPE 'UPDATE) (AND [OR (NULL NAME) (find X in NAME suchthat (AND (EQ (CAR X) AT) (EQ (CADR X) PROP] (SETQ VAL (CONS (LIST AT PROP) VAL] ((OR (EQ NAME T) (AND (EQ (CAR NAME) AT) (EQ (CADR NAME) PROP))) (RETFROM (FUNCTION INFILECOMS?) T)) ((NULL NAME) (SETQ VAL (CONS (LIST AT PROP) VAL]) (IFCPROPS [LAMBDA (COM) (* bvm%: " 2-Dec-83 14:24") (* ;;; "Examine a PROPS com for objects of specified TYPE") (SELECTQ TYPE (PROPS (* ;  "the PROPS command can actually take (PROPNAME at1 at2 ...)") (INFILEPAIRS (INFILECOMTAIL COM))) (PROP (* ;  "return the atoms which have any properties at all") (for PAIR in (INFILECOMTAIL COM) do (for ATNAME inside (CAR PAIR) do (INFILECOMSVAL ATNAME )))) (MACROS (* ; "only MACRO properties") (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR) (CDR PAIR)))) NIL]) (IFCEXPRTYPE [LAMBDA (COM FN) (* ; "Edited 6-Apr-87 20:20 by Pavel") (* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN") (for SUBCOM in (INFILECOMTAIL COM) when (AND (EQ (CAR SUBCOM) FN) (EQ (CAR (LISTP (CADR SUBCOM))) 'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM)) T]) (IFCPROPSCAN [LAMBDA (ATOMS PROPNAMES) (* ; "Edited 2-Aug-88 02:20 by masinter") (* ;;; "Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES") (for AT in ATOMS WHEN (LITATOM AT) unless [COND [(EQ ONFILETYPE 'UPDATE) (COND (NAME (NOT (ASSOC AT NAME] ((LISTP NAME) (NEQ AT (CAR NAME] do (COND ((EQ PROPNAMES 'ALL) (for PROP in (GETPROPLIST AT) by (CDDR PROP) when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP))) (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP]) (IFCDECLARE [LAMBDA (TAIL WANTDECLARE) (* ; "Edited 8-Jun-90 18:11 by teruuchi") (PROG ((TAIL TAIL)) LP (COND ((LISTP TAIL) [SELECTQ (CAR TAIL) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL) (CADR TAIL] (SETQ TAIL (CDR TAIL))) (DONTEVAL@LOAD [COND ((OR (\STKSCAN 'DOFILESLOAD) (\STKSCAN 'LOAD)) (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"") (RETURN)) (WANTDECLARE (INFILECOMSVAL (CAR TAIL]) (COMPILERVARS (RETURN)) (COND [(FMEMB (CAR TAIL) DECLARETAGSLST) (COND (WANTDECLARE (INFILECOMSVAL (CAR TAIL] (T (INFILECOM (CAR TAIL] (SETQ TAIL (CDR TAIL)) (GO LP]) (INFILEPAIRS [LAMBDA (LST) (* lmm " 4-DEC-78 09:51") (for LL in LST do (for X inside (CAR LL) do (for Y inside (CDR LL) do (INFILECOMSVAL (LIST X Y]) (INFILECOMSMACRO [LAMBDA (ATS PROPS) (* lmm "28-SEP-78 18:35") (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it. --- Normally (e.g. for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom. However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties") (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE) (EVERY (PROPNAMES AT) (FUNCTION (LAMBDA (X) (OR (NOT (FMEMB X MACROPROPS)) (EQMEMB X PROPS] [SOME MACROPROPS (FUNCTION (LAMBDA (PROP) (EQMEMB PROP PROPS] (INFILECOMSVAL AT]) ) (* ;; "adding to a file") (DEFINEQ (FILES? [LAMBDA NIL (* bvm%: "27-Oct-86 18:14") (* ;;; "Display each file needing dumping, etc. For files needing dumping, display details of why.") (UPDATEFILES) (LET (FILES CHANGES PRINTED) (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED of (LISTP (fetch FILEPROP of FILE] do (if (NOT PRINTED) then (LISPXPRIN1 "To be dumped: " T) (SETQ PRINTED T)) (LISPXPRIN2 FILE T) (LISPXPRIN1 " ...changes to " T) [for CH in CHANGES bind TB do (COND ((LISTP CH) [COND (TB (LISPXTAB TB NIL T)) (T (SETQ TB (POSITION T] (LISPXPRIN2 (CAR CH) T) (FILES?PRINTLST (CDR CH))) (T (* ; "old style") (LISPXPRIN2 CH T) (LISPXSPACES 1 T] (LISPXTERPRI T)) (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED " plus ")) do (SETQ FLG T) finally (if FLG then (OR PRINTED (LISPXPRIN1 "...to be dumped. " T)) (ADDTOFILES?))) (if (SETQ FILES NOTCOMPILEDFILES) then (FILES?PRINTLST FILES "To be compiled: ") (LISPXTERPRI T)) (if (SETQ FILES NOTLISTEDFILES) then (FILES?PRINTLST FILES "To be listed: ") (LISPXTERPRI T)) (CL:VALUES]) (FILES?1 [LAMBDA (TYPE FIRST) (* bvm%: "27-Oct-86 18:17") (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.") (LET (STR LST) (COND ([AND (LITATOM TYPE) (SETQ STR (fetch DESCRIPTION of TYPE)) (LISTP (SETQ LST (fetch CHANGED of TYPE] (AND FIRST (LISPXPRIN1 FIRST T)) (LISPXPRIN1 '"the " T) (LISPXPRIN1 STR T) (FILES?PRINTLST LST) (LISPXTERPRI T) T]) (FILES?PRINTLST [LAMBDA (LST STR) (* bvm%: "27-Oct-86 18:15") (* ;; "Print elements of LST separated by commas and indenting new lines a bunch. If MAPRINT had a left margin arg, this would be simpler.") (MAPRINT LST T (OR STR ": ") NIL ", " [FUNCTION (LAMBDA (STR) (COND ((> (+ (POSITION T) (NCHARS STR T T) 3) (LINELENGTH NIL T)) (LISPXTERPRI T) (LISPXPRIN1 " " T))) (LISPXPRIN2 STR T T] T]) (ADDTOFILES? [LAMBDA (NOASKSTR) (* ; "Edited 10-Aug-2020 21:18 by rmk:") (* ; "Edited 21-Aug-91 10:13 by jds") (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says") (* ;; "RMK: Eliminated literal CR's in the key list.") (ERSETQ (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS] (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g. changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES") [COND (NOASKSTR (PRIN1 NOASKSTR T)) (T (DOBE) (SETQ BUFS (READP T)) (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go") `([Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL] [N ,(CONCAT "o" (CHARACTER (CHARCODE EOL] (%] ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL))) EXPLAINSTRING "] - nowhere, all items will be marked as dummy " NOECHOFLG T)) T) (N (RETURN)) (%] (* ; "Nowhere") (for TYPE in FILEPKGTYPES do (for NAME in (fetch (FILEPKGTYPE CHANGED) of TYPE) do (ADDTOFILE NAME TYPE NIL))) (RETURN)) NIL) (* ;  "if there was type-ahead BEFORE the askuser, then don't allow it now") (COND (BUFS (SETQ BUFS (COND ((READP T) (LINBUF) (SYSBUF) (SETQ BUFS (CLBUFS NIL T READBUF] [for TYPE STR LST in FILEPKGTYPES when [AND (SETQ STR (fetch DESCRIPTION of TYPE)) (LISTP (SETQ LST (COND ((EQ TYPE 'VARS) VARSCHANGES) (T (fetch (FILEPKGTYPE CHANGED) of TYPE] do (printout T "(" STR ")" T) (for NAME TEM FILE in LST when NAME do (PROG NIL LP (PRIN2 NAME T) (SPACES 2 T) (* ;; "if user typed ahead before entering addtofiles?? then dont allow typeahead here, because it will justgobble his earlier typeahead.") (* ;; "SELCHARQ to avoid literal CR") (SELCHARQ (CHCON1 (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T))) (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T) (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer") (DOBE))) (GO LP)) (%] (* ; "Nowhere") (SETQ FILE)) (SPACE (* ; "No action") (RETURN)) ((LF =) (PRINT (OR (SETQ FILE LASTFILE) 'Nowhere) T)) (SETQ FILE TEM)) (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR) (SETQ PLACE (WHATIS FILE NIL TYPE)) [COND ((LITATOM PLACE) (* ; "file name") (SETQ FILE PLACE) (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE)) NAME TYPE NEAR LISTNAME) (ADDNEWCOM COMSNAME NAME TYPE NIL FILE)) (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE)) (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.") ) ((EQ (CAR PLACE) 'Near%:) (SETQ NEAR (CADR PLACE)) (COND ([SOME FILELST (FUNCTION (LAMBDA (FL) (ADDTOCOMS (FILECOMS (SETQ FILE FL)) NAME TYPE NEAR LISTNAME] (PRINT (LIST 'on FILE) T T)) (T (PRINT (LIST (CADR PLACE) 'not 'found) T T) (ERROR!))) (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))) ([OR [UNDONLSETQ (PROGN (SAVESET (SETQ LISTNAME (CAR PLACE)) (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME)) T) T 'NOPRINT) (OR (SETQ FILE (CAR (WHEREIS NAME TYPE FILELST))) (ERROR!] (SOME FILELST (FUNCTION (LAMBDA (X) (ADDTOCOMS (FILECOMS (SETQ FILE X)) NAME TYPE NEAR LISTNAME] (PRIN1 " value is filed on " T) (PRINT FILE T T) (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE)) (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed") ) (T (PRIN1 " put list " T) (PRIN2 (CAR PLACE) T T) (SETQ FILE (WHATIS (ASKUSER NIL NIL " on file: " '(("" "" EXPLAINSTRING "a file name" KEYLST ())) T) 'FILE)) (SAVESET (CAR PLACE) (MERGEINSERT NAME (LISTP (GETTOPVAL (CAR PLACE))) T) T 'NOPRINT) (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.") (ADDNEWCOM (FILECOMS FILE) NAME TYPE (CAR PLACE) FILE) (for F in (fetch WHENFILED of TYPE) do (for I in (GETTOPVAL (CAR PLACE)) do (APPLY* F I TYPE FILE] (AND FILE (ADDFILE FILE)) (SETQ LASTFILE PLACE))) (GO LP] (AND BUFS (BKBUFS BUFS)) (UPDATEFILES]) (ADDTOFILE [LAMBDA (NAME TYPE FILE NEAR LISTNAME) (* lmm "21-Nov-84 11:43") (* ; "adds NAME to the file FILE") (PROG (TEM COMSNAME) [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T) (COND ((FMEMB TYPE FILELST) (GETFILEPKGTYPE (swap TYPE FILE))) (T (GETFILEPKGTYPE TYPE] (SETQ FILE (WHATIS FILE 'FILE)) (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE)) NAME TYPE NEAR LISTNAME) (ADDNEWCOM COMSNAME NAME TYPE NIL FILE)) (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE)) (AND FILE (NOT (FMEMB FILE FILELST)) (ADDFILE FILE)) (RETURN FILE]) (WHATIS [LAMBDA (USERINPUT ONLY) (* lmm "28-Nov-84 16:49") (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble; if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable") (PROG (TEM UCASE) (RETURN (COND ((NULL USERINPUT) (* ; "nowhere") NIL) [(LISTP USERINPUT) (COND (ONLY (ERROR!)) (T (SELECTQ (CAR USERINPUT) ((@ Near%:) (CONS 'Near%: (CDR USERINPUT))) (WHATIS (CAR USERINPUT) 'LIST] ([AND (NEQ ONLY 'LIST) (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT))) FILELST) (LISTP (GETTOPVAL (FILECOMS UCASE))) (SETQ TEM (FIXSPELL UCASE NIL FILELST T] TEM) ((AND (NEQ ONLY 'FILE) (LISTP (GETTOPVAL USERINPUT))) (LIST USERINPUT)) ((AND (NEQ ONLY 'LIST) (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE) NIL T) 'Y)) UCASE) ((AND (NEQ ONLY 'FILE) (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT) NIL T) 'Y)) (LIST USERINPUT)) (T (* ; "none of above") (ERROR!]) (ADDTOCOMS [LAMBDA (COMS NAME TYPE NEAR LISTNAME) (* rmk%: "10-JUN-82 22:53") (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms); return NIL if unsuccessful. If LISTNAME is given, then only insert by adding to LISTNAME. If NEAR is given, only insert near it") (COND ((NULL COMS) NIL) [(LITATOM COMS) (* ;  "given a name of a command; rebind COMSNAME to current variable and try to add to its value") (OR [PROG ((COMSNAME COMS)) (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME)) NAME TYPE NEAR (AND (NEQ COMS LISTNAME) LISTNAME] (AND (EQ COMS LISTNAME) (ADDNEWCOM COMS NAME TYPE] (T (SETQ TYPE (GETFILEPKGTYPE TYPE)) (for TAIL on COMS do (COND [(LISTP (CAR TAIL)) (COND ((ADDTOCOM (CAR TAIL) NAME TYPE NEAR LISTNAME) (RETURN T] (T (SELECTQ (CAR TAIL) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (SETQ TAIL (CDR TAIL))) NIL]) (ADDTOCOM [LAMBDA (COM NAME TYPE NEAR LISTNAME) (* ; "Edited 2-May-87 19:04 by Pavel") (* ;  "tries to insert NAME into the prettycom COM; returns NIL if unsuccessful") (PROG (TEM) (COND ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM] (RETURN))) [COND ((SETQ TEM (fetch ADD of (CAR COM))) (RETURN (COND ((OR (NULL LISTNAME) (INFILECOMS? LISTNAME 'FILEVARS (LIST COM))) (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR)) (MARKASCHANGED COMSNAME 'VARS)) TEM] (RETURN (SELECTQ (CAR COM) (FNS (AND (EQ TYPE 'FNS) (ADDTOCOM1 COM NAME NEAR LISTNAME))) ((VARS INITVARS) (COND ((OR (EQ (CAR COM) 'VARS) NEAR LISTNAME) (* ;  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.") (SELECTQ TYPE (EXPRESSIONS (COND ((EQ (CAR NAME) 'SETQ) (ADDTOCOM1 COM (CDR NAME) NEAR LISTNAME)))) (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME)) NIL)))) (COMS (ADDTOCOMS (COND [(EQ (CADR COM) '*) (COND ((LITATOM (CADDR COM)) (CADDR COM)) (T (RETURN] (T (CDR COM))) NAME TYPE NEAR LISTNAME)) (DECLARE%: (AND (OR LISTNAME NEAR) (ADDTOCOMS (COND [(EQ (CADR COM) '*) (COND ((LITATOM (CADDR COM)) (CADDR COM)) (T (RETURN] (T (CDR COM))) NAME TYPE NEAR LISTNAME))) (CL:EVAL-WHEN (AND (OR LISTNAME NEAR) (ADDTOCOMS (COND [(EQ (CL:THIRD COM) '*) (COND ((LITATOM (CL:FOURTH COM)) (CL:FOURTH COM)) (T (RETURN] (T (CDDR COM))) NAME TYPE NEAR LISTNAME))) ((PROP IFPROP) (SELECTQ TYPE (PROPS (COND ((EQ (CADR COM) (CADR NAME)) (ADDTOCOM1 (CDR COM) (CAR NAME) NEAR LISTNAME)) ((AND (EQ (CAR NAME) (CADDR COM)) (NULL (CDDDR COM))) [/RPLACA (CDR COM) (UNION (MKLIST (CDR NAME)) (MKLIST (CADR COM] (MARKASCHANGED COMSNAME 'VARS) T))) (MACROS (COND ([AND (for PROP inside (CADR COM) always (EQMEMB PROP MACROPROPS)) (for PROP in MACROPROPS always (OR (EQMEMB PROP (CADR COM)) (NOT (GETPROP NAME PROP] (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed") (ADDTOCOM1 (CDR COM) NAME NEAR LISTNAME)))) NIL)) ((PROPS ALISTS) (AND (EQ TYPE (CAR COM)) (ADDTOCOM1 COM (/NCONC1 (OR [ASSOC (CAR NAME) (COND [(EQ (CADR COM) '*) (COND [(LITATOM (CADDR COM)) (AND (OR (NULL LISTNAME) (EQ (CADDR COM) LISTNAME)) (GETTOPVAL (CADDR COM] (T (RETURN] (T (CDR COM] (LIST (CAR NAME))) (CADR NAME)) NEAR LISTNAME))) (P (COND ((AND (EQ TYPE 'EXPRESSIONS) (NEQ (CAR NAME) 'SETQ)) (ADDTOCOM1 COM NAME NEAR LISTNAME)))) (AND (EQ (CAR COM) TYPE) (ADDTOCOM1 COM NAME NEAR LISTNAME]) (ADDTOCOM1 [LAMBDA (COM NAME NEAR LISTNAME) (* rmk%: " 3-JAN-82 22:53") (COND [(EQ (CADR COM) '*) (* ; "add to list name") (AND [COND (LISTNAME (EQ (CADDR COM) LISTNAME)) (T (LITATOM (CADDR COM] (SAVESET (CADDR COM) [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM] (COND ((AND NEAR (SETQ NEAR (MEMBER NEAR COM))) (/RPLACD NEAR (CONS NAME (CDR NEAR))) COM) (T (MERGEINSERT NAME COM T] T 'NOPRINT] ((NULL LISTNAME) (* ; "add to standard com") [AND (NOT (MEMBER NAME (CDR COM))) (COND [(SETQ NEAR (MEMBER NEAR COM)) (/RPLACD NEAR (CONS NAME (CDR NEAR] (T (/RPLACD COM (MERGEINSERT NAME (CDR COM] (MARKASCHANGED COMSNAME 'VARS) T]) (ADDNEWCOM [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE) (* rmk%: " 3-JAN-82 22:53") (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE. --- if LISTNAME is given, then use it as the listname") (PROG (NEWCOM OLDCOM TAIL) (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE)) [COND ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME))) (RETURN (SAVESET COMSNAME (LIST NEWCOM) T 'NOPRINT] LP [COND ((OR (NLISTP (SETQ OLDCOM (CAR TAIL))) (SELECTQ (CAR OLDCOM) ((LOCALVARS SPECVARS BLOCKS) T) (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM))) NIL)) (/ATTACH NEWCOM TAIL)) ((LISTP (CDR TAIL)) (SETQ TAIL (CDR TAIL)) (GO LP)) (T (/RPLACD TAIL (LIST NEWCOM] (MARKASCHANGED COMSNAME 'VARS]) (MAKENEWCOM [LAMBDA (NAME TYPE LISTNAME FILE) (* ; "Edited 8-Apr-87 14:55 by Pavel") (SETQ TYPE (GETFILEPKGTYPE TYPE)) (PROG (TEM) (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname") (AND (LISTP NAME) (SETQ NAME (COPY NAME))) (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE)) (APPLY* TEM NAME TYPE LISTNAME FILE)) (SELECTQ TYPE (PROPS [AND (NULL LISTNAME) (CONS 'PROP (CONS (COND ((AND (LISTP (CDR NAME)) (NULL (CDDR NAME))) (CADR NAME)) (T (CDR NAME))) (OR (LISTP (CAR NAME)) (LIST (CAR NAME]) (EXPRESSIONS [COND ((EQ (CAR NAME) 'SETQ) (MAKENEWCOM (CDR NAME) 'VARS LISTNAME FILE)) (T (CONS 'P (COND (LISTNAME (LIST '* LISTNAME)) (T (LIST NAME]) NIL) (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE]) (DEFAULTMAKENEWCOM [LAMBDA (NAME TYPE LISTNAME FILE) (* lmm "20-OCT-82 22:48") (COND ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST) (fetch MACRO of TYPE) (fetch GETDEF of TYPE))) (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION of TYPE) TYPE) T)) ((NULL DEFAULTCOMHASFILEFLG) (* ; "disable FOOFNS FOOVARS junk") (LIST TYPE NAME)) ((EQ FILE T) (* ;  "FILE=T only when called from SHOWDEF") (LIST TYPE NAME)) ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE)) (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME)) T) T 'NOPRINT] (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items") (LIST TYPE '* LISTNAME)) (T (LIST TYPE NAME]) ) (RPAQ? DEFAULTCOMHASFILEFLG ) (ADDTOVAR MARKASCHANGEDFNS ) (DEFINEQ (MERGEINSERT [LAMBDA (NEW LST ONEFLG) (* lmm "30-Jun-86 18:11") (* ;; "searches LST to find the most reasonable place to insert NEW. Does nothing if ONEFLG is T and NEW is already a member of LST") (COND ((AND ONEFLG (MEMBER NEW LST)) LST) ((LISTP NEW) (/NCONC1 LST NEW)) (T (PROG ((N 0) LST1 PLACE TEM) (SETQ LST1 LST) LP (* ;; "finds the function with the longest leading common substring. The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.") (COND ((NULL LST1) (GO OUT)) ((OR (LISTP (CAR LST1)) (SETQ TEM (STRPOS (CAR LST1) NEW 1 NIL T T))) (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE") (SETQ PLACE LST1) (GO OUT)) ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1) NEW)) N) (SETQ N TEM) (SETQ PLACE LST1))) (SETQ LST1 (CDR LST1)) (GO LP) OUT (SETQ TEM (CAR PLACE)) (OR [SOME (OR PLACE LST) (FUNCTION (LAMBDA (X LST) (COND ([OR (ALPHORDER NEW X) (AND PLACE (NOT (ALPHORDER TEM X] (* ;; "for example, if the FNS list is something like (... FOO FOO1 ...) where the ... may or may not be in order, e.g. (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.") (/ATTACH NEW LST)) (T (SETQ TEM X) NIL] (SETQ LST (/NCONC1 LST NEW))) (RETURN LST]) (MERGEINSERT1 [LAMBDA (X Y) (* rmk%: "24-MAY-82 00:05") (* ;; "value is the number of leading characters of X and Y that agree.") (PROG ((N 1) C1 C2) LP [COND ((OR (NULL (SETQ C1 (NTHCHARCODE X N))) (NULL (SETQ C2 (NTHCHARCODE Y N))) (NEQ C1 C2)) (RETURN (SUB1 N] (SETQ N (ADD1 N)) (GO LP]) ) (* ;; "RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file" ) (RPAQ ADDTOFILEKEYLST `(("[" "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" NOECHOFLG T) (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T) (,(CHARACTER (CHARCODE LF)) "" EXPLAINSTRING "{line-feed} - same as previous response" NOECHOFLG T) (" " ,(CONCATCODES (LIST (CHARCODE SPACE) (CHARCODE EOL))) EXPLAINSTRING "{space} - no action" NOECHOFLG T) ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL))) EXPLAINSTRING ,(CONCAT "] - nowhere, item is marked as a dummy" (CHARACTER (CHARCODE EOL))) NOECHOFLG T) ["(" "List: (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE)) ,(CHARACTER (CHARCODE EOL] RETURN (CDR ANSWER] (@ "Near: " EXPLAINSTRING "@ other-item -- put the item near the other item" NOECHOFLG T KEYLST (( "" CONFIRMFLG [,(CHARACTER (CHARCODE EOL] RETURN ANSWER))) [,(CHARACTER (CHARCODE CR)) "" RETURN ,(CHARACTER (CHARCODE SPACE] ("" "File name: " EXPLAINSTRING "a file name" KEYLST ()))) (RPAQQ LASTFILE NIL) (* ;; "deleting an item from a file") (DEFINEQ (DELFROMFILES [LAMBDA (NAME TYPE FILES) (* rmk%: " 6-MAR-82 13:16") (* ;; "Eliminates NAME as an item of type TYPE in COMS.") (PROG (COMS) (SETQ TYPE (GETFILEPKGTYPE TYPE)) (RETURN (for FILE inside (OR FILES FILELST) when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE)) NAME TYPE) (COND ((INFILECOMS? NAME TYPE COMS) (printout T "(could not delete " NAME " from " FILE ")" T)))) collect (for FN in (fetch WHENUNFILED of TYPE) do (APPLY* FN NAME TYPE FILE)) FILE]) (DELFROMCOMS [LAMBDA (COMS NAME TYPE) (* bvm%: " 1-Oct-86 22:02") (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list). Returns T if it does anything") (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.") (COND [(LITATOM COMS) (LET ((COMSNAME COMS)) (DECLARE (SPECVARS COMS)) (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME))) (DELFROMCOMS COMS NAME TYPE] (T (PROG (DONE) (SETQ TYPE (GETFILEPKGTYPE TYPE)) LP (COND ((NLISTP COMS) (RETURN DONE))) [COND ((LISTP (CAR COMS)) (SELECTQ (DELFROMCOM (CAR COMS) NAME TYPE) (ALL (/RPLNODE2 COMS (CDR COMS)) (SETQQ DONE ALL) (GO LP)) (NIL) (SETQ DONE T))) (T (SELECTQ (CAR COMS) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (SETQ COMS (CDR COMS))) (COND ((AND (EQ TYPE 'VARS) (EQ NAME (CAR COMS))) (/RPLNODE2 COMS (CDR COMS)) (SETQ DONE T) (GO LP] (SETQ COMS (CDR COMS)) (GO LP]) (DELFROMCOM [LAMBDA (COM NAME TYPE) (* ; "Edited 2-May-87 19:02 by Pavel") (* ; "Tries to delete NAME from COM") (PROG (TEM VAR NEW) (COND ((SETQ TEM (fetch DELETE of (CAR COM))) (AND (SETQ TEM (APPLY* TEM COM NAME TYPE)) (MARKASCHANGED COMSNAME 'VARS)) (RETURN TEM))) (RETURN (SELECTQ (CAR COM) ((DECLARE%: COMS) (DELFROMCOMS (COND [(EQ (CADR COM) '*) (COND ((LITATOM (CADDR COM)) (CADDR COM)) (T (RETURN] (T (CDR COM))) NAME TYPE)) ((CL:EVAL-WHEN) (DELFROMCOMS (COND [(EQ (CL:THIRD COM) '*) (COND ((LITATOM (CL:FOURTH COM)) (CL:FOURTH COM)) (T (RETURN] (T (CDDR COM))) NAME TYPE)) ((ALISTS PROPS) (AND (EQ TYPE (CAR COM)) (COND ((EQ (CADR COM) '*) (COND ([AND (LITATOM (SETQ VAR (CADDR COM))) (SETQ TEM (ASSOC (CAR NAME) (GETTOPVAL VAR))) (NEQ (CDR TEM) (SETQ TEM (REMOVEITEM (CADR NAME) (CDR TEM] (SAVESET VAR TEM T 'NOPRINT) T))) ([AND [CDR (SETQ TEM (ASSOC (CAR NAME) (CDR COM] (NEQ (CDR TEM) (SETQ NEW (REMOVEITEM (CADR NAME) (CDR TEM] (/RPLACD TEM NEW) (MARKASCHANGED COMSNAME 'VARS) T)))) (BLOCKS (* ;; "Remove function name from blocks declarations. This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.") [AND (EQ TYPE 'FNS) (for BLOCK in (INFILECOMTAIL COM T) do (AND (MEMB NAME BLOCK) (/DREMOVE NAME BLOCK)) (for X in BLOCK when (AND (LISTP X) (MEMB NAME (CDR X))) do (/RPLACD X (REMOVE NAME (CDR X]) ((PROP IFPROP) [SELECTQ TYPE (PROPS (RETURN (COND ((EQ (CADR COM) (CADR NAME)) (DELFROMCOM1 (CDR COM) (CAR NAME))) ((AND (EQMEMB (CADR NAME) (CADR COM)) [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM] (EQ (CAR TEM) (CAR NAME))) [/RPLACA (CDR COM) (REMOVE (CADR NAME) (MKLIST (CADR COM] (MARKASCHANGED COMSNAME 'VARS) T)))) (COND ([for PROP inside (CADR COM) always (EQ TYPE (GETPROP PROP 'PROPTYPE] (DELFROMCOM1 (CDR COM) NAME]) ((RECORDS INITRECORDS SYSRECORDS) (AND (EQ TYPE 'RECORDS) (DELFROMCOM1 COM NAME))) (P (AND (EQ TYPE 'EXPRESSIONS) (DELFROMCOM1 COM NAME))) ((VARS INITVARS) (AND (EQ TYPE 'VARS) (DELFROMCOM1 COM NAME T))) (AND (EQ TYPE (CAR COM)) (DELFROMCOM1 COM NAME]) (DELFROMCOM1 [LAMBDA (COM NAME FLG) (* rmk%: "10-JUN-82 22:44") (* ;;  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed") (LET (TEM VAL) (COND ((EQ (CADR COM) '*) (COND ([AND (LITATOM (SETQ TEM (CADDR COM))) (NEQ (SETQ VAL (GETTOPVAL TEM)) (SETQ VAL (REMOVEITEM NAME VAL FLG] (SAVESET TEM VAL T 'NOPRINT) T))) ((NEQ (CDR COM) (SETQ TEM (REMOVEITEM NAME (CDR COM) FLG))) (/RPLACD COM TEM) (MARKASCHANGED COMSNAME 'VARS) T]) (REMOVEITEM [LAMBDA (X LST FLG) (* ; "Edited 25-May-88 17:52 by drc:") (* lmm "10-FEB-78 17:29") (* ;;  "returns a subset of LST with X deleted; if FLG is set, also remove elements whose CAR is X") (COND [[OR (MEMBER X LST) (AND FLG (SOME LST (FUNCTION (LAMBDA (Y) (EQUAL (CAR (LISTP Y)) X] (SUBSET LST (FUNCTION (LAMBDA (Y) (AND (NOT (EQUAL Y X)) (OR (NOT FLG) (NLISTP Y) (NOT (EQUAL (CAR Y) X] (T LST]) (MOVETOFILE [LAMBDA (TOFILE NAME TYPE FROMFILE) (* rmk%: "18-OCT-79 19:51") (* ; "To move items between files") (SETQ TYPE (GETFILEPKGTYPE TYPE)) [COND ((OR (EQ TYPE 'FNS) FROMFILE) (* ;  "FNS definition can reside on file if LOADFNS was done. This guarantees that it is loaded.") (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM] (AND (EQ TYPE 'FNS) (MARKASCHANGED NAME TYPE)) (* ;  "FNS won't get dumped unless they are `changed'") (DELFROMFILES NAME TYPE FROMFILE) (ADDTOFILE NAME TYPE TOFILE]) ) (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T) (MOVD? 'MOVETOFILE 'MOVEITEM NIL T) (ADDTOVAR SYSPROPS PROPTYPE VARTYPE) (* ; "functions for doing things and marking them changed and auxiliary functions") (DEFINEQ (SAVEPUT [LAMBDA (ATM PROP VAL) (* lmm " 7-May-84 16:56") (* ;; "analogous to SAVESET but also marks changed property lists; LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT") [COND ((NOT (LITATOM ATM)) (ERRORX (LIST 14 ATM] (PROG ((X (GETPROPLIST ATM)) X0 TEM OLDFLG) LOOP (COND ((NLISTP X) (COND ((AND (NULL X) X0) (* ;  "typical case. property list ran out on an even parity position. e.g. (A B C D)") (SETQ TEM (LIST PROP VAL)) (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM) LISPXHIST)) (FRPLACD (CDR X0) TEM) (GO RET))) (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning") ) ((NLISTP (CDR X)) (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g. (A B C) or (A B C . D) fall through and add at beginning.") ) [(EQ (CAR X) PROP) (SETQ OLDFLG (NEQ (EQUALN (CADR X) VAL 400) T)) (* ; "i.e. it probably changed") (/RPLACA (CDR X) VAL) (COND ((NOT OLDFLG) (GO RET1)) (T (OR (EQ DFNFLG T) (LISPXPRINT (LIST 'new PROP 'property 'for ATM) T T)) (GO RET] (T (SETQ X (CDDR (SETQ X0 X))) (GO LOOP))) [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM] (SETPROPLIST ATM TEM) (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM) LISPXHIST)) RET (MARKASCHANGED (LIST ATM PROP) 'PROPS (NOT OLDFLG)) RET1 (AND ADDSPELLFLG (ADDSPELL ATM 0)) (RETURN VAL]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT) (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT)) ) (DEFINEQ (UNMARKASCHANGED [LAMBDA (NAME TYPE) (* JonL "24-Jul-84 19:59") (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties. Value is name if anything is done") (PROG (ANYFLG) (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE] while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL) (SETQ ANYFLG T)) [for F TAIL PROP TYPEDPROP in FILELST when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED of (SETQ PROP (fetch FILEPROP of F] do (SETQ ANYFLG T) (COND ((SETQ TAIL (REMOVE (CAR TAIL) (CDR TYPEDPROP))) (/RPLACD TYPEDPROP TAIL)) (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP (fetch TOBEDUMPED of PROP] (RETURN (AND ANYFLG NAME]) (PREEDITFN [LAMBDA (ATM TYPE EDITCHANGES) (* rmk%: "18-FEB-82 21:49") (* ;  "EDITL is advised to call this before editing something") (AND FILEPKGFLG (SELECTQ TYPE (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS) (CONS)) CLISPARRAY)) (for X in (GETPROPLIST ATM) do (OR (NLISTP X) (GETHASH X CLISPARRAY) (PUTHASH X (CONS (CAR X) (CDR X)) CLISPARRAY] (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made") [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS) EDITCHANGES (APPEND (GETPROPLIST ATM]) (VARS [COND ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE)) [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS) (CONS)) CLISPARRAY)) (for X in (EVALV ATM) do (OR (NLISTP X) (GETHASH X CLISPARRAY) (PUTHASH X (CONS (CAR X) (CDR X)) CLISPARRAY] (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS) EDITCHANGES (for X in (EVALV ATM) collect (CAR X]) NIL]) (POSTEDITPROPS [LAMBDA (EDITCHANGES OLDPROPS) (* rmk%: "18-FEB-82 21:50") (* ; "was RESETSAVE'd from PREEDITFN") (PROG (OV FOUNDCHANGE) (OR FILEPKGFLG (RETURN)) (COND ((CADR EDITCHANGES) (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP) when (for OLDPROP on OLDPROPS by (CDDR OLDPROP) do (COND ((EQ (CAR OLDPROP) (CAR NEWPROP)) (* ; "Found the property") [AND (EQ (CADR OLDPROP) (CADR NEWPROP)) (COND ((NLISTP (CADR OLDPROP)) (* ; "value is same") (RETURN)) ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP) CLISPARRAY)) (EQ (CAADR NEWPROP) (CAR OV)) (EQ (CDADR NEWPROP) (CDR OV))) (PUTHASH (CADR NEWPROP) NIL CLISPARRAY) (* ;  "value has been edited (CLISPARRAY translation went away)") (RETURN] (RETURN T))) finally (* ; "didn't find the property") (RETURN T)) do (MARKASCHANGED (LIST (CAR EDITCHANGES) (CAR NEWPROP)) 'PROPS NIL) (SETQ FOUNDCHANGE T)) (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES) NIL]) (POSTEDITALISTS [LAMBDA (EDITCHANGES OLDTOKENS) (* rmk%: " 4-JAN-82 10:14") (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES] (* ;  "called after an ALIST has been edited") (OR FILEPKGFLG (RETURN)) (COND ((CADR EDITCHANGES) (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES)) do (MARKASCHANGED (LIST (CAR EDITCHANGES) X) 'ALISTS NIL) (SETQ FOUNDCHANGE T)) [for NEWENTRY in NEWENTRIES do (COND ([AND (LISTP NEWENTRY) (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY)) (EQ (CAR NEWENTRY) (CAR OV)) (EQ (CDR NEWENTRY) (CDR OV] (PUTHASH NEWENTRY NIL CLISPARRAY) (MARKASCHANGED (LIST (CAR EDITCHANGES) (CAR NEWENTRY)) 'ALISTS NIL) (SETQ FOUNDCHANGE T] (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES) NIL]) ) (ADDTOVAR LISPXFNS (PUT . SAVEPUT) (PUTPROP . SAVEPUT)) (* ; "sub-functions for file package commands & types") (DEFINEQ (ALISTS.GETDEF [LAMBDA (NAME TYPE OPTIONS) (* Pavel " 7-Oct-86 17:24") (AND (LISTP NAME) (CL:SYMBOLP (CAR NAME)) (LET [(ASSOCIATION (ASSOC (CADR NAME) (GETTOPVAL (CAR NAME] (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME) ASSOCIATION]) (ALISTS.WHENCHANGED [LAMBDA (NAME TYPE NEWFLG) (* lmm "16-OCT-78 20:02") (* ;  "called by MARKASCHANGED when an ALIST entry has changed") (PROG [(VARTYPE (GETPROP (CAR NAME) 'VARTYPE] (AND (LISTP VARTYPE) (EQ (CAR VARTYPE) 'ALIST) (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME) (CADR VARTYPE) NEWFLG]) (CLEARCLISPARRAY [LAMBDA (NAME TYPE REASON) (DECLARE (SPECVARS NAME TYPE REASON)) (* lmm "14-Aug-84 15:03") (AND CLISPARRAY (MAPHASH CLISPARRAY (COND [(EQ TYPE 'I.S.OPRS) (FUNCTION (LAMBDA (TRAN FORM) (AND (MEMB NAME FORM) (PUTHASH FORM NIL CLISPARRAY] (T (* ; "MACRO changed") (FUNCTION (LAMBDA (TRAN FORM) (COND ((OR (EQ NAME (CAR FORM)) (EQ (CAR (GETPROP (CAR FORM) 'CLISPWORD)) 'CHANGETRAN)) (PUTHASH FORM NIL CLISPARRAY]) (EXPRESSIONS.WHENCHANGED [LAMBDA (EXPR) (* ; "Edited 6-Apr-87 20:21 by Pavel") (SELECTQ (CAR EXPR) ((SETQ SETQQ) (UNMARKASCHANGED (CADR EXPR) 'VARS)) ((PROGN PROG) (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X))) NIL]) (MAKEALISTCOMS [NLAMBDA X (* rmk%: "14-OCT-83 13:34") (* ;; "make command to dump prettydefmacros") (LIST (CONS 'ADDVARS (for PR in X join (for ALISTNAME inside (CAR PR) collect (CONS ALISTNAME (for ATNAME inside (CDR PR) bind ENTRY when (SETQ ENTRY (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME)) (PROGN (LISPXPRINT (LIST 'no ATNAME 'entry 'on ALISTNAME) T T) NIL))) collect ENTRY]) (MAKEFILESCOMS [NLAMBDA FILES (* JonL "12-FEB-83 19:02") (* ;; "This scans the command just to warn the user about any errors. Must match up with the big SELECTQ in FILESLOAD NIL") [for FILE in FILES do (OR (LITATOM FILE) (while (LISTP FILE) do (SELECTQ (CAR (OR (LISTP FILE) (RETURN))) ((LOADCOMP LOADFROM)) (FROM (pop FILE) (if (OR (EQ (CAR FILE) 'VALUEOF) (if (AND (EQ (CAR FILE) 'VALUE) (EQ (CADR FILE) 'OF)) then (pop FILE))) then (pop FILE))) ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR)) (OR (FMEMB (CAR FILE) LOADOPTIONS) (PRINT (CONS (CAR FILE) '(-- unrecognized FILES option)) T))) (pop FILE] (CONS 'FILESLOAD FILES]) (MAKELISPXMACROSCOMS [NLAMBDA X (* lmm " 5-SEP-78 23:15") (PROG (TEM TEM2) (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X (FUNCTION (LAMBDA (Z) (FASSOC Z LISPXHISTORYMACROS ] (LIST (CONS 'LISPXHISTORYMACROS TEM))) (AND [SETQ TEM (SUBSET X (FUNCTION (LAMBDA (Z) (FASSOC Z LISPXMACROS ] (LIST (CONS 'LISPXMACROS TEM] (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z) (FMEMB Z LISPXCOMS] (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2] (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z) (FMEMB Z HISTORYCOMS] (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2]) (MAKEPROPSCOMS [NLAMBDA X (* lmm "26-FEB-78 17:10") (* ;; "make command to dump PROPS") (for PAIR in X collect (CONS 'PROP (CONS (COND ((AND (LISTP (CDR PAIR)) (NULL (CDDR PAIR))) (CADR PAIR)) (T (CDR PAIR))) (OR (LISTP (CAR PAIR)) (LIST (CAR PAIR]) (MAKEUSERMACROSCOMS [NLAMBDA X (* rmk%: " 3-JAN-82 23:20") (PROG (TEM) [COND [X (for Y in X do (OR (FASSOC Y USERMACROS) (FASSOC Y EDITMACROS) (LISPXPRINT (CONS Y '(-- no entry on USERMACROS)) T T] (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR)) X] (RETURN (LIST (CONS 'ADDVARS (NCONC (for VAR in '(USERMACROS EDITMACROS) when (SETQ TEM (for Y in (GETTOPVAL VAR) when (FMEMB (CAR Y) X) collect Y)) collect (CONS VAR TEM)) (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS DONTSAVEHISTORYCOMS) when [SETQ TEM (SUBSET (GETTOPVAL LST) (FUNCTION (LAMBDA (Y) (OR (FMEMB Y X) (AND (LISTP Y) (FMEMB (CAR Y) X] collect (CONS LST TEM]) (PROPS.WHENCHANGED [LAMBDA (NAME TYPE NEWFLG) (* lmm " 7-SEP-78 22:08") (PROG [(PROPTYPE (GETPROP (CADR NAME) 'PROPTYPE] (COND [PROPTYPE (RETFROM 'MARKASCHANGED (COND ((NEQ PROPTYPE 'IGNORE) (MARKASCHANGED (CAR NAME) PROPTYPE NEWFLG] (T (SELECTQ (CADR NAME) (CLISPWORD (CLEARCLISPARRAY (CAR NAME))) NIL]) (FILEGETDEF.LISPXMACROS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:12") (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (EQ FIRST 'ADDTOVAR) (MEMB SECOND '(LISPXMACROS LISPXCOMS)) T] when (SELECTQ (CADR X) (LISPXMACROS (* ;  "Rebuild the expressions cause there might be other elements in the ADDTOVAR") (AND (SETQ X (ASSOC NAME (CDDR X))) (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X)))) (LISPXCOMS [COND ((MEMB NAME (CDDR X)) (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME))) ((SETQ X (ASSOC NAME (CDDR X))) (* ; "For synonym pairs") (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X]) NIL) collect X]) (FILEGETDEF.ALISTS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:13") (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (EQ FIRST 'ADDTOVAR) (EQ SECOND (CAR NAME] when (SETQ X (ASSOC (CADR NAME) (CDDR X))) collect X finally (RETURN (COND ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME) $$VAL]) (FILEGETDEF.RECORDS [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND) (* lmm "26-Jun-86 15:56") (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (MEMB FIRST CLISPRECORDTYPES) (OR (EQ SECOND NAME) (AND (MEMB SECOND '(%( %[)) (PROGN (RATOM) (RATOM) (RATOM) (EQ NAME (RATOM] (if (EQ (CAAR VAL) 'NOT-FOUND%:) then NOTFOUND elseif (CDR VAL) then (CONS 'PROGN VAL) else (CAR VAL]) (FILEGETDEF.PROPS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:13") (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (EQ FIRST 'PUTPROPS) (EQ SECOND (CAR NAME] join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL) (CADR NAME)) join (LIST (CAR TAIL) (CADR TAIL))) finally (RETURN (COND ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME) $$VAL]) (FILEGETDEF.MACROS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm "28-May-86 09:51") (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (FMEMB FIRST '(PUTPROPS DEFMACRO)) (EQ SECOND NAME] join (if (EQ (CAR X) 'DEFMACRO) then (LIST X) else (for TAIL on (CDDR X) by (CDDR TAIL) when (FMEMB (CAR TAIL) MACROPROPS) collect (LIST 'PUTPROPS (CADR X) (CAR TAIL) (CADR TAIL]) (FILEGETDEF.VARS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:14") (for X in (LOADFNS NIL SOURCE 'GETDEF NAME) do (SELECTQ (CAR X) ((RPAQQ SETQQ) (RETURN (CADDR X))) ((RPAQ SETQ RPAQ?) (RETURN (EVAL (CADDR X)))) NIL) finally (RETURN 'NOBIND]) (FILEGETDEF.FNS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* 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)) (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) (RETURN (WITH-READER-ENVIRONMENT ENV [COND ((EQMEMB 'ARGLIST OPTIONS) (RATOM SOURCE) (READ SOURCE) (RATOM SOURCE) (LIST (READ SOURCE) (READ SOURCE))) (T (CADR (READ SOURCE])] (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE]) (FILEPKGCOMS.PUTDEF [LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "15-Jul-85 11:29") (PROG (COM TYP) [SELECTQ (CAR (LISTP DEFINITION)) (COM (SETQ COM (CDR DEFINITION))) (TYPE (SETQ TYP (CDR DEFINITION))) (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION))) (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION] (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE") (for I in COM by (CDDR I) do (SELECTQ I ((ADD DELETE MACRO CONTENTS CONTAIN COM)) (ERROR I "not file package command property" ))) (* ;  "COM merely adds to spelling list, for builtins") [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS) (LISTGET COM 'CONTAIN] (* ; "Until CONTAIN is de-documented.") (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP (LISTGET COM PROP))) [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS) (SELECTQ I ((DESCRIPTION TYPE)) (ERROR I "not file package type/command property" ] (* ;  "TYPE merely adds to spelling list, for builtins") (for PROP in (UNION '(DESCRIPTION TYPE) FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP (LISTGET TYP PROP]) (FILES.PUTDEF [LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "15-Jul-85 17:13") (PROGN (PUTDEF (FILECOMS NAME) 'VARS (CAR DEFINITION) REASON) (* ; "DEFINE THE COMS") (ADDFILE NAME) (* ;  "MAKE SURE IT IS A FILE PACKAGE ENTITY") [/replace TOBEDUMPED of (fetch FILEPROP of NAME) (FILEPKG.MERGECHANGES (CADR DEFINITION) (fetch TOBEDUMPED of (fetch FILEPROP of NAME] (OR (fetch FILEDATES of NAME) (/replace FILEDATES of NAME with (CADDR DEFINITION]) (VARS.PUTDEF [LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "29-Jul-85 20:59") (/SETTOPVAL NAME DEFINITION T]) (FILES.WHENCHANGED [LAMBDA (NAME TYPE REASON) (MARKASCHANGED (FILECOMS NAME) 'VARS REASON]) ) (ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO) (ADDTOVAR SYSPROPS PROPTYPE) (PUTPROPS I.S.OPR PROPTYPE I.S.OPRS) (PUTPROPS SUBR PROPTYPE IGNORE) (PUTPROPS LIST PROPTYPE IGNORE) (PUTPROPS CODE PROPTYPE IGNORE) (PUTPROPS FILEDATES PROPTYPE IGNORE) (PUTPROPS FILE PROPTYPE IGNORE) (PUTPROPS FILEMAP PROPTYPE IGNORE) (PUTPROPS EXPR PROPTYPE FNS) (PUTPROPS VALUE PROPTYPE VARS) (PUTPROPS COPYRIGHT PROPTYPE FILES) (PUTPROPS FILETYPE PROPTYPE FILES) (PUTPROPS BAKTRACELST VARTYPE ALIST) (PUTPROPS BREAKMACROS VARTYPE ALIST) (PUTPROPS COMPILETYPELST VARTYPE ALIST) (PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS)) (PUTPROPS ERRORTYPELST VARTYPE ALIST) (PUTPROPS FONTDEFS VARTYPE ALIST) (PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS)) (PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS)) (PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS)) (PUTPROPS PRETTYEQUIVLST VARTYPE ALIST) (PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST) (PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST) (PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS)) (* ; "Define the commands below AFTER the various properties have been established.") (ADDTOVAR USERMACROS (M NIL (MAKE FILE FILE)) (M (X . Y) (E (MARKASCHANGED (COND ((LISTP 'X) (CAR 'X)) (T 'X)) 'USERMACROS) T) (ORIGINAL (M X . Y)))) (ADDTOVAR EDITMACROS (M (X . Y) (E (MARKASCHANGED (COND ((LISTP 'X) (CAR 'X)) (T 'X)) 'USERMACROS) T) (ORIGINAL (M X . Y)))) (ADDTOVAR EDITCOMSA M) (ADDTOVAR EDITCOMSL M) (* ; "GETDEF methods") (DEFINEQ (RENAME [LAMBDA (OLD NEW TYPES FILES METHOD) (* JonL "24-Jul-84 20:01") (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD))) (* ;; "special kludge: change the callers BEFORE if we are changing a field; this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message") [for TYPE inside TYPES when (NEQ TYPE 'FIELDS) do (COPYDEF OLD NEW TYPE NIL (COND ((EQ TYPE 'VARS) 'NOERROR] (CHANGECALLERS OLD NEW TYPES FILES METHOD) [for TYPE inside TYPES do (COND ((AND (EQ TYPE 'FIELDS) (HASDEF OLD 'FIELDS)) (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file. Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.") (COPYDEF OLD NEW 'FIELDS)) (T (DELDEF OLD TYPE] (RETURN NEW]) (CHANGECALLERS [LAMBDA (OLD NEW AS-TYPES FILES METHOD) (* ; "Edited 6-Dec-86 01:25 by lmm") (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES)) REL TEM EDITCOMS FNS) (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD)) [SETQ EDITCOMS (LIST (COND [(OR (EQMEMB 'CAREFUL METHOD) (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES)) (printout T "Warning --" OLD " is also defined as " TEM T))) (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename. Y means do it, No means skip, anything else goes into TTY.") (SUBPAIR '(OLD NEW) (LIST OLD NEW) '(BIND (LPQ (F OLD N) (MARK %#1) (ORR (1 !0 P) NIL) (MARK %#2) (COMS (SELECTQ (ASKUSER NIL NIL " Replace ? " '((Y "Yes ") (N "No ") (% "") (% "") (% "") (& "")) NIL NIL '(NOECHOFLG T)) (Y '(R1 OLD NEW)) (N NIL) 'TTY%:)) (MARK %#3) (IF (EQ (%## (\ %#3)) (%## (\ %#2))) ((\ %#1)) NIL] (T (LIST 'R OLD NEW] (SELECTQ (COND ((AND (EQMEMB 'MASTERSCOPE METHOD) MSDATABASELST (for TYPE inside AS-TYPES do [COND ((SETQ TEM (SELECTQ TYPE ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 'CALL) (MACROS '(CALL DIRECTLY)) ((VARS VARIABLES) '(USE OR BIND)) ((RECORDS FIELDS I.S.OPRS) (LIST 'USE 'AS TYPE)) (RETURN NIL))) (COND (REL (SETQ REL (LIST TEM 'OR REL))) (T (SETQ REL TEM] FINALLY (RETURN REL))) (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known") 'MASTERSCOPE) ((EQMEMB 'EDITCALLERS METHOD) 'EDITCALLERS) (T 'SEARCH)) (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND ((NULL FILES) (UPDATEFILES) (FILEPKGCHANGES 'FNS] (for FILE inside (OR FILES FILELST) join (FILEFNSLST FILE] (FUNCTION UPDATEFN)) (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL)) T) FNS))) (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST) when (SETQ TEM (EDITCALLERS OLD X T)) collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM))) X)))) (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST X)))) (ERROR "UNRECOGNIZED RENAME METHOD" METHOD)) (AND (EQMEMB 'FNS AS-TYPES) (FMEMB OLD FNS) (SETQ FNS (REMOVE OLD FNS))) (EDITFROMFILE FNS FILES OLD EDITCOMS) [for TYPE inside AS-TYPES do (for FILE in (WHEREIS OLD TYPE FILES) do (AND (ADDTOFILE NEW TYPE FILE) (DELFROMFILES OLD TYPE FILE) (printout T OLD " changed to " NEW " on " FILE))) (COND ((SETQ TEM (WHEREIS OLD TYPE FILES)) (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM] (COND (REL (UPDATECHANGED) (COND ((AND (SETQ TEM (GETRELATION OLD REL T)) (WHEREIS TEM 'FNS FILES)) (printout T "Couldn't find where " OLD " is referenced in " TEM T]) ) (DEFINEQ (SHOWDEF [LAMBDA (NAME TYPE FILE) (* ; "Edited 16-Apr-2018 21:35 by rmk:") (* ;  "prettyprint NAME as it would be dumped as a TYPE") (RESETLST (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP) (DECLARE (SPECVARS . T)) [AND FILE (NEQ FILE (OUTPUT)) (if (SETQ FL (OPENP FILE 'OUTPUT)) then (RESETSAVE (OUTPUT FL)) else (OUTFILE FILE) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (OUTPUT] (PRETTYCOM (MAKENEWCOM NAME TYPE))))]) (COPYDEF [LAMBDA (OLD NEW TYPE SOURCE OPTIONS) (* lmm "14-Aug-84 18:38") (* ; "like MOVD, but takes a type.") (PROG (TEM DEF) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) [SETQ DEF (GETDEF OLD TYPE SOURCE (COND ((EQ OPTIONS 'NOCOPY) NIL) (T (REMOVE 'NOCOPY (MKLIST OPTIONS] (* ;  "The default is for GETDEF to return a COPY. Make sure that NOCOPY isn't in options though.") (SELECTQ TYPE (VARS) (FILES [for X in (CAR DEF) do (* ;  "change all the listnames which are of form filenameTYPE") (SELECTQ (CAR X) ((PROP IFPROP) (SETQ X (CDR X))) NIL) (COND ((EQ (CADR X) '*) (SETQ X (CDDR X)) (COND ((AND (LITATOM (CAR X)) (SETQ TEM (STRPOS OLD (CAR X) 1 NIL T T))) (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X) TEM -1))) (COPY (GETTOPVAL (CAR X))) T) (FRPLACA X TEM]) ((PROPS ALISTS) (OR (EQ (CAR NEW) (CAR OLD)) (DSUBST (CAR NEW) (CAR OLD) DEF)) (OR (EQ (CADR NEW) (CADR OLD)) (DSUBST (CADR NEW) (CADR OLD) DEF))) (DSUBST NEW OLD DEF)) (PUTDEF NEW TYPE DEF) (RETURN NEW]) (GETDEF [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm "13-Jul-85 04:10") (* ;; "returns the definition of NAME as a TYPE from SOURCE; cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found. The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.") (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS))) (DECLARE (SPECVARS NOCOPY)) (SELECTQ OPTIONS (0 (SETQQ OPTIONS (NOERROR NODWIM)) (SETQ NOCOPY T)) (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST)) (SETQ NOCOPY T)) (T (SETQQ OPTIONS SPELL)) NIL) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (SELECTQ SOURCE (0 (SETQQ SOURCE CURRENT)) (T (SETQQ SOURCE SAVED)) (NIL (SETQQ SOURCE ?)) NIL) [SELECTQ SOURCE (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS))) (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS] (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR)) (fetch NULLDEF of TYPE)) (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR)) (fetch NULLDEF of TYPE)) (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS]) (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS))) (COND ((AND (LISTP SOURCE) (EQ (CAR SOURCE) '=)) (SETQ DEF (CDR SOURCE))) (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS)) (SETQ NOCOPY T] (OR NOCOPY (SETQ DEF (COPY DEF))) (COND ((AND (EQ TYPE 'FNS) (NOT (EQMEMB 'NODWIM OPTIONS))) (DWIMDEF DEF NAME SOURCE))) (RETURN DEF]) (GETDEFCOM [LAMBDA (X) (* lmm " 4-Jul-85 13:31") (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in. Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed. --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion. That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.") (* ; "a RETFROM point") (for Y in X join (GETDEFCOM0 Y]) (GETDEFCOM0 [LAMBDA (COM) (* wt%: " 7-FEB-79 23:28") (PROG (TEM) (RETURN (COND ((SETQ TEM (fetch MACRO of (CAR COM))) (* COND ((fetch CONTENTS of  (CAR COM)) (* ;  "if it has a CONTENTS function, generally means it is not safe to evaluate")  (RETFROM (QUOTE GETDEFCOM)))) (for Y in (SUBPAIR (CAR TEM) (PRETTYCOM1 COM) (CDR TEM)) join (GETDEFCOM0 Y))) (T (SELECTQ (CAR COM) (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X))) (ADDVARS (for Y in (PRETTYCOM1 COM) collect (CONS 'ADDTOVAR Y))) (APPENDVARS (for Y in (PRETTYCOM1 COM) collect (CONS 'APPENDTOVAR Y))) (P (APPEND (PRETTYCOM1 COM))) (RETFROM 'GETDEFCOM]) (GETDEFCURRENT [LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 2-May-87 19:00 by Pavel") (* ;  "Gets the current definition--source=0") (LET (DEF) (COND ((AND (SETQ DEF (fetch GETDEF of TYPE)) (NEQ DEF T)) (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.") (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS)) (fetch NULLDEF of TYPE)) (GETDEFERR NAME TYPE OPTIONS)) DEF) (T (OR (NEQ [SETQ DEF (SELECTQ TYPE (FNS (AND (LITATOM NAME) (EXPRP (SETQ DEF (VIRGINFN NAME))) DEF)) (VARS (if (LITATOM NAME) then (GETTOPVAL NAME) else 'NOBIND)) ((FIELDS RECORDS) (if (LITATOM NAME) then [SETQ DEF (SELECTQ TYPE (RECORDS (RECLOOK NAME)) (MKPROGN (FIELDLOOK NAME] (if (EQMEMB 'EDIT OPTIONS) then (COPY DEF) else DEF))) (FILES (* ;  "what is the `definition' of a file? -- I guess the COMS which say what it contains") [if (LITATOM NAME) then (if (SETQ DEF (GETFILEDEF NAME)) then (UPDATEFILES) (LIST (LISTP (GETTOPVAL (FILECOMS DEF))) (fetch TOBEDUMPED of (fetch FILEPROP of DEF)) (LISTP (fetch FILEDATES of DEF]) (TEMPLATES (if (AND (LITATOM NAME) (SETQ DEF (GETTEMPLATE NAME))) then (LIST 'SETTEMPLATE (KWOTE NAME) (KWOTE DEF)))) (MACROS [if [AND (LITATOM NAME) (SETQ DEF (for X on (GETPROPLIST NAME) by (CDDR X) when (FMEMB (CAR X) MACROPROPS) join (LIST (CAR X) (CADR X] then `(PUTPROPS ,NAME ,@DEF]) (EXPRESSIONS (LISTP NAME)) (PROPS [AND (LISTP NAME) (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME)) [FUNCTION (LAMBDA (X) (EQ X (CADR NAME] (FUNCTION CDDR))) (LIST 'PUTPROPS (CAR NAME) (CADR NAME) (CADR DEF]) (FILEPKGCOMS [AND (LITATOM NAME) (PROG ((COM (FILEPKGCOM NAME)) (TYP (FILEPKGTYPE NAME))) (RETURN (COND ((AND COM TYP) (LIST (CONS 'COM COM) (CONS 'TYPE TYP))) (COM (LIST (CONS 'COM COM))) (TYP (LIST (CONS 'TYPE TYP]) (FILEVARS (COND ((AND (LITATOM NAME) (LISTP (SETQ DEF (GETTOPVAL NAME))) (WHEREIS NAME 'FILEVARS)) DEF) (T 'NOBIND))) (LET ((COMS (LIST (MAKENEWCOM NAME TYPE))) FILE) [COND ((NOT (SETQ DEF (GETDEFCOM COMS))) (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (RESETLST (RESETSAVE PRETTYFLG) (RESETSAVE FONTCHANGEFLG) [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH] (PRETTYDEFCOMS COMS) (SETFILEPTR FILE 0) [SETQ DEF (for X in (READFILE FILE) join (SELECTQ (CAR X) ((*) NIL) (DECLARE%: (for Y on (CDR X) unless (SELECTQ (CAR Y) ((COPYWHEN EVAL@LOADWHEN EVAL@COMPILEWHEN) (RETURN (LIST Y))) (FMEMB (CAR Y) DECLARETAGSLST)) collect (CAR Y))) (CL:EVAL-WHEN (CDDR X)) (PROGN (CDR X)) (LIST X] (SETQ NOCOPY T)))] (MKPROGN DEF] (fetch NULLDEF of TYPE)) (GETDEFERR NAME TYPE OPTIONS)) DEF]) (GETDEFERR [LAMBDA (NAME TYPE OPTIONS MSG) (* lmm "13-Jul-85 04:11") (DECLARE (USEDFREE NODEF)) (* ;  "Message non-null if looking for saved or filed definition.") (PROG (TEM) (RETURN (COND ((EQMEMB 'NOERROR OPTIONS) (* ;  "We want to do the string search in the HASDEF case") (RETURN (fetch NULLDEF of TYPE))) [(AND (NULL MSG) (EQMEMB 'SPELL OPTIONS) (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS) 'SPELL) T))) (NEQ TEM NAME)) (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS] (T (for O inside OPTIONS when (STRINGP O) do (RETFROM 'GETDEF O) finally (ERROR NAME (CONS TYPE '(definition not found)) T]) (GETDEFFROMFILE [LAMBDA (NAME TYPE SOURCE OPTIONS) (* bvm%: " 1-Oct-86 22:10") (* ;; "Tries to get definition from source file. If successful, returns the definition. Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.") (DECLARE (SPECVARS NAME)) (bind (NOTFOUND _ "not found") DEF SOURCE TEM2 for FILE inside (COND ((EQ SOURCE 'FILE) (WHEREIS NAME TYPE T)) (T SOURCE)) when (AND (SETQ SOURCE (FINDFILE FILE T)) (NEQ [SETQ DEF (COND ((SETQ TEM2 (fetch FILEGETDEF of TYPE)) (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND)) (T (SELECTQ TYPE (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND)) ((VARS FILEVARS) (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND)) (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND)) (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND)) (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND)) (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND)) (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND)) (COND [(SETQ DEF (GET TYPE 'DEFINERS)) (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF `(LAMBDA (FIRST SECOND) (AND (MEMB FIRST ',DEF) (OR (EQ SECOND NAME) (AND (MEMB SECOND '(%( %[)) (PROGN (RATOM) (RATOM) (RATOM) (EQ NAME (RATOM] (* ; "ick! Should use real closure") (if (EQ (CAAR VAL) 'NOT-FOUND) then NOTFOUND elseif (CDR VAL) then (CONS 'PROGN VAL) else (CAR VAL] (T (RESETLST (RESETSAVE (RESETUNDO)) [LET (LOAD-VERBOSE-STREAM) (DECLARE (SPECVARS LOAD-VERBOSE-STREAM)) (* ;  "just in case we get a PRETTYCOMPRINT in here") (LOADFNS NIL SOURCE 'PROP (COND ((LITATOM NAME) (* ;  "If an atom, only bother with expressions that contain it") (CONS (LIST '& '|..| NAME))) (T T] (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))] NOTFOUND)) do (AND (EQ SOURCE 'FILE) (OR (FMEMB FILE FILELST) (CL:FORMAT T "(from ~A)~%%" SOURCE))) (* ;  "Copying and dwimifying are done in GETDEF") (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS (APPEND '(no definition on) (MKLIST SOURCE]) (GETDEFSAVED [LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 11-Aug-87 18:14 by cutting") (* ;  "Gets the `saved' definition--source=T") (SELECTQ TYPE (FNS (OR (GETPROP NAME 'EXPR) (GETDEFERR NAME TYPE OPTIONS "no saved definition for"))) (VARS (* ;  "The value of a variable is never substituted into and never COPIED") (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X) 'VALUE) do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS "no saved value for ")))) (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS))) (GETDEFERR NAME TYPE OPTIONS "no saved definition for "]) (PUTDEF [LAMBDA (NAME TYPE DEFINITION REASON) (* ; "Edited 8-Apr-87 12:52 by Pavel") (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE))) (COND (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON)) (T (SELECTQ TYPE (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON)) (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON)) (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON)) (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON)) (EVAL DEFINITION)) NAME]) (EDITDEF [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (DECLARE (LOCALVARS . T) (SPECVARS SOURCE)) (* ; "Edited 27-Jul-87 11:04 by cutting") (* ;; "lets you edit anything. Given name and type, call editor on the definition (loading it in from SOURCE if necessary). If you change it, then the definition gets unsaved. OPTIONS is passed through from ED to the editor.") (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (COND ((AND (fetch EDITDEF of TYPE) (APPLY* (fetch EDITDEF of TYPE) NAME TYPE SOURCE EDITCOMS OPTIONS))) ((AND (EQ TYPE 'FNS) (NULL SOURCE)) (* ;  "special hack for EDITDEF of FNS because of ability to EDITLOADFNS") (EDITDEF.FNS NAME EDITCOMS OPTIONS)) (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS))) NAME]) (DEFAULT.EDITDEF [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (* ; "Edited 11-Jun-92 16:26 by cat") (PROG [(DEF (COND [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY] [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR] [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR] (T (LET ((FILES (WHEREIS NAME TYPE T))) (CL:IF (NULL FILES) (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE) [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME FILES) (CL:IF (CL:ENDP (CDR FILES)) (CL:IF (CL:Y-OR-N-P "Shall I load this file PROP? ") (CAR FILES)) (ASKUSER NIL NIL "indicate which file to load PROP: " (MAKEKEYLST FILES) T))] (CL:WHEN FILE (LOAD FILE 'PROP) (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])] (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.") (DECLARE (SPECVARS RETRY)) (* ;; "what is RETRY ???") (SETQ RETRY) (CL:WHEN DEF (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG) (* ;  "this function is called when there were changes made") (FIXEDITDATE DEF) (* ; "fix the edit date first - jtm") (PUTDEF NAME TYPE DEF) (MARKASCHANGED NAME TYPE 'CHANGED) (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition. doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here. this sometimes results in MARKASCHANGED getting called twice.") ] OPTIONS))]) (EDITDEF.FILES [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (* ; "Edited 18-Mar-87 16:07 by woz") (EDITDEF (FILECOMS NAME) 'VARS SOURCE EDITCOMS OPTIONS]) (LOADDEF [LAMBDA (NAME TYPE SOURCE) (* lmm "13-SEP-78 01:34") (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY]) (DWIMDEF [LAMBDA (DEF FN SOURCE) (* lmm " 6-Jun-86 17:23") (AND [OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (CADDR DEF)) 'CLISP%:) (SELECTQ SOURCE ((CURRENT SAVED FILE ?) NIL) (AND (LITATOM SOURCE) (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE] (LET ((NOSPELLFLG T) (DWIMESSGAG T) FILEPKGFLG LISPXHIST) (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST)) (DWIMIFY0 DEF (COND ((OR (LISTP FN) (NULL FN)) '?) (T FN)) NIL DEF]) (DELDEF [LAMBDA (NAME TYPE) (* ; "Edited 5-Dec-86 06:20 by lmm") (PROG (TEM) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) LP [COND ((SETQ TEM (fetch DELDEF of TYPE)) (APPLY* TEM NAME TYPE)) (T (SELECTQ TYPE (FNS (* ;  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such") (AND (EXPRP NAME) (/PUTD NAME)) (REMPROP NAME 'EXPR) [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME]) (VARS (/SETTOPVAL NAME 'NOBIND)) (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES) do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST] (/replace FILEPROP of NAME with NIL) (/replace FILECHANGES of NAME with NIL) (/replace FILEDATES of NAME with NIL) (FLUSHFILEMAPS NAME)) (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME) (DELFROMLIST 'FILEPKGTYPES NAME) (for FIELD on (FILEPKGCOM NAME) by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD) NIL)) (for FIELD on (FILEPKGTYPE NAME) by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD) NIL)) (/replace ALLFIELDS of NAME with NIL)) (ALISTS [AND (LISTP NAME) (DELFROMLIST (CAR NAME) (FASSOC (CADR NAME) (GETTOPVAL (CAR NAME]) (MACROS (for P in MACROPROPS do (/REMPROP NAME P))) (PROPS (AND (LISTP NAME) (/REMPROP (CAR NAME) (CADR NAME)))) (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS)) (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS )) (DELFROMLIST 'LISPXCOMS NAME) (DELFROMLIST 'HISTORYCOMS NAME)) (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet") T] (MARKASCHANGED NAME TYPE 'DELETED) (RETURN NAME]) (DELFROMLIST [LAMBDA (VAR VAL) (* rmk%: " 3-JAN-82 23:22") (AND (FMEMB VAL (GETTOPVAL VAR)) (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR) (FUNCTION (LAMBDA (X) (AND (NEQ X VAL) (OR (NLISTP X) (NEQ (CDR X) VAL]) (HASDEF [LAMBDA (NAME TYPE SOURCE SPELLFLG) (* ; "Edited 31-Aug-87 18:02 by drc:") (* ;; "is NAME the name of something of type TYPE? NIL SOURCE means 0, not ?") (DECLARE (SPECVARS TYPE)) (COND [[OR (LISTP TYPE) (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG") (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE)) (RETURN $$VAL] (T (PROG [(NODEF (fetch NULLDEF of TYPE)) (OPTS '(NODWIM NOCOPY NOERROR HASDEF] (COND ((NULL SOURCE) (SETQQ SOURCE CURRENT))) (RETURN (SELECTQ SOURCE ((CURRENT 0) [COND ([OR (MEMBER NAME (fetch CHANGED of TYPE)) (LET ((TM (fetch HASDEF of TYPE))) (COND (TM (APPLY* TM NAME TYPE SOURCE)) [(NOT (LITATOM NAME)) (SELECTQ TYPE (PROPS (AND (LISTP NAME) (GETPROP (CAR NAME) (CADR NAME)))) ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS FIELDS USERMACROS FILEVARS FILEPKGCOMS) NIL) (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS] (T (* ;; "symbol definitions") (SELECTQ TYPE (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS") "INTERLISP"))) (AND SYMBOL (BOUNDP SYMBOL)))) (TEMPLATES (GETTEMPLATE NAME)) (MACROS (GETLIS NAME MACROPROPS)) (LISPXMACROS (OR (FASSOC NAME LISPXMACROS) (FASSOC NAME LISPXHISTORYMACROS))) (VARS (AND (NOT (CL:KEYWORDP NAME)) (NEQ (GETTOPVAL NAME) 'NOBIND))) (RECORDS (RECLOOK NAME)) (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD] (RETURN (AND TEM (EQ (CAR TEM) 'FORWORD) (GETPROP (CDR TEM) 'I.S.OPR]) (FNS (AND (OR (AND (GETD NAME) (EXPRP (GETD NAME))) (GET NAME 'EXPR)) (NOT (HASDEF NAME 'FUNCTIONS SOURCE)))) (FIELDS (RECORDFIELD? NAME)) (USERMACROS (FASSOC NAME USERMACROS)) (FILEVARS) ((PROPS ALISTS DEFS EXPRESSIONS) NIL) (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST) (FMEMB NAME FILEPKGTYPES))) (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS] (OR NAME T)) (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME) (FIXSPELL NAME NIL (SELECTQ TYPE (FILES FILELST) (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES)) (FIELDS (for X in USERRECLST join (APPEND (RECORDFIELDNAMES X)))) (RECORDS (for X in USERRECLST when (LITATOM (CADR X)) collect (CADR X))) (LISPXMACROS LISPXCOMS) (I.S.OPRS I.S.OPRLST) (USERMACROS (MAPCAR USERMACROS (FUNCTION CAR))) USERWORDS) NIL (LISTP SPELLFLG) [FUNCTION (LAMBDA (X) (HASDEF X TYPE 'CURRENT] NIL T))]) (? (OR (HASDEF NAME TYPE 'CURRENT) (AND (LITATOM NAME) (HASDEF NAME TYPE 'SAVED SPELLFLG)) (WHEREIS NAME TYPE T))) ((SAVED T) (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS))) (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS]) (GETFILEDEF [LAMBDA (FILENAME) (* lmm " 4-Jul-85 13:25") (* ;;  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST") (COND ((FMEMB FILENAME FILELST) FILENAME) (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T) do (COND ((EQ (FILENAMEFIELD FILE 'NAME) FILENAME) (RETURN FILE]) (SAVEDEF [LAMBDA (NAME TYPE DEFINITION) (* JonL "24-Jul-84 20:11") (COND [(AND (LISTP NAME) (NULL TYPE)) (MAPCAR NAME (FUNCTION (LAMBDA (I) (SAVEDEF I 'FNS] (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME))) (/PUT NAME [SETQ TYPE (COND ((SUBRP DEFINITION) 'SUBR) ((EXPRP DEFINITION) 'EXPR) ((CCODEP DEFINITION) 'CODE) (T 'LIST] DEFINITION))) (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME))) 'NOBIND) (EQ DEFINITION (GETTOPVAL NAME)) (/PUT NAME (SETQ TYPE 'VALUE) DEFINITION))) (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT '(NOCOPY NOERROR NODWIM] (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS)) (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME)) SAVEDDEFS] TYPE]) (UNSAVEDEF [LAMBDA (NAME TYPE DEF) (* lmm " 6-Jun-86 17:24") (SELECTQ TYPE ((NIL EXPR CODE SUBR LIST) (COND [(LISTP NAME) (* ; "for compatibility") (MAPCAR NAME (FUNCTION (LAMBDA (X) (UNSAVED1 X TYPE] (T (UNSAVED1 NAME TYPE)))) (PROG NIL [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) 'SAVED 0)) (RETURN (CONS TYPE '(not found] (COND ((NEQ DFNFLG T) (SAVEDEF NAME TYPE) (LET ((DFNFLG T)) (PUTDEF NAME TYPE DEF))) (T (PUTDEF NAME TYPE DEF))) (RETURN TYPE]) (COMPAREDEFS [LAMBDA (NAME TYPE SOURCES) (* lmm " 4-Jul-85 14:37") (COND ((AND (LISTP TYPE) (GETFILEPKGTYPE SOURCES NIL T)) (swap TYPE SOURCES))) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T] [COND ((NULL SOURCES) (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE)) (SOME SRCS (FUNCTION (LAMBDA (FILE) (MEMBER NAME (CDR (ASSOC TYPE (fetch TOBEDUMPED of (fetch FILEPROP of FILE] (push SRCS 'CURRENT] (SETQ SRCS (for SRC in SRCS when (COND ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY] (fetch NULLDEF of TYPE)) (OR [SOME DEFS (FUNCTION (LAMBDA (DP) (COMPARELST DEF (CDR DP] (push DEFS (CONS SRC DEF))) T) (T (PRINTOUT T "No " SRC " definition found for " NAME T) NIL)) collect SRC)) (RETURN (COND ((NULL SRCS) '(no definitions found)) ((NULL (CDR SRCS)) '(only one definition found)) ((CDR DEFS) [for S1 on (DREVERSE DEFS) do (for S2 on (CDR S1) do (PRIN2 NAME T T) (AND (CAAR S1) (PRIN1 " from " T) (PRIN2 (CAAR S1) T T)) (PRIN1 " and " T) (PRIN2 NAME T T) (COND ((CAAR S2) (PRIN1 " from " T) (PRIN2 (CAAR S2) T T))) (PRIN1 " differ:" T) (TERPRI T) (COMPARELISTS (CDAR S1) (CDAR S2] 'DIFFERENT) (T 'SAME]) (COMPARE [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2) (* lmm " 5-SEP-78 13:37") (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY] (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY] (COND ((COMPARELST DEF1 DEF2) (RETURN))) (PRIN2 NAME1 T T) (COND (SOURCE1 (PRIN1 " from " T) (PRIN2 SOURCE1 T T))) (PRIN1 " and " T) (PRIN2 NAME2 T T) (COND (SOURCE2 (PRIN1 " from " T) (PRIN2 SOURCE2 T T))) (PRIN1 " differ:" T) (TERPRI T) (COMPARELISTS DEF1 DEF2) (RETURN T]) (TYPESOF [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER) (* ; "Edited 2-Aug-88 02:08 by masinter") (* ;; "return list of all known types which NAME names") (LET (FOUND SHADOWED) (if (FMEMB SOURCE '(? NIL)) then (CL:FLET [(RSHADOW NIL (for X in FOUND do (for Y in (CDR (FASSOC X SHADOW-TYPES)) do (if (FMEMB Y FOUND) then (* ; "shadower found before shadowed") (SETQ FOUND (REMOVE Y FOUND] (LET (NOTFOUND NEWTYPES) (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES) when [AND (LITATOM TYPE) (NOT (EQMEMB TYPE IMPOSSIBLETYPES)) (OR (NULL FILTER) (CL:FUNCALL FILTER TYPE)) (NOT (find X in FOUND suchthat (FMEMB TYPE (CDR (FASSOC X SHADOW-TYPES] do (if [OR (HASDEF NAME TYPE 'CURRENT) (AND (LITATOM NAME) (HASDEF NAME TYPE 'SAVED] then (push FOUND TYPE) else (push NOTFOUND TYPE))) (RSHADOW) [for FILE in FILELST while NOTFOUND when [NEQ T (fetch LOADTYPE of (GETPROP FILE 'FILE] do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND (FILECOMS FILE) 'TYPESOF)) then [bind X for TYPE in NEWTYPES when (FMEMB TYPE NOTFOUND) do (push FOUND TYPE) (if (SETQ X (FASSOC TYPE SHADOW-TYPES)) then (SETQ NOTFOUND (LDIFFERENCE NOTFOUND X)) else (SETQ NOTFOUND (REMOVE TYPE NOTFOUND] (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES] (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF)) then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND)) (SETQ FOUND (UNION NEWTYPES FOUND))) (RSHADOW) FOUND)) else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES) when (AND (LITATOM TYPE) (NOT (EQMEMB TYPE IMPOSSIBLETYPES)) (OR (NULL FILTER) (CL:FUNCALL FILTER TYPE)) (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE))) FOUND]) ) (RPAQ? WHEREIS.HASH ) (* ; "Must come after PUTDEF") (DEFINEQ (FIXEDITDATE [LAMBDA (EXPR) (* ; "Edited 17-Jul-89 11:13 by jtm:") (* NOBIND "18-JUL-78 21:11") (* Inserts or replaces previous edit  date) (AND INITIALS (LISTP EXPR) (LISTP (CDR EXPR)) (PROG (E) (COND ((FMEMB (CAR EXPR) LAMBDASPLST) (* ;; "insert the edit date after the argument list") (SETQ E (CDDR EXPR))) [(FMEMB (GETPROP (CAR EXPR) ':DEFINER-FOR) EDITDATE-ARGLIST-DEFINERS) (* ;; "insert the edit date after the argument list") (SETQ E (CDDR EXPR)) (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E)) finally (SETQ E (CDR E] ((FMEMB (GETPROP (CAR EXPR) ':DEFINER-FOR) EDITDATE-NAME-DEFINERS) (* ;; "insert the edit date after the name") (SETQ E (CDDR EXPR))) (T (RETURN))) RETRY [COND ((NLISTP E) (RETURN)) ((LISTP (CAR E)) (SELECTQ (CAAR E) ((CLISP%: DECLARE) (SETQ E (CDR E)) (GO RETRY)) (BREAK1 (COND ((EQ (CAR (CADAR E)) 'PROGN) (SETQ E (CDR (CADAR E))) (GO RETRY)))) (ADV-PROG (* No easy way to mark cleanly the  date of an advised function) (RETURN)) (COND ((AND (EQ (CAAR E) COMMENTFLG) (EQ (CADAR E) 'DECLARATIONS%:)) (SETQ E (CDR E)) (GO RETRY] (COND ([for TAIL on E while (AND (LISTP (CAR TAIL)) (EQ (CAAR TAIL) COMMENTFLG)) do (COND ((AND (LISTP (CDR TAIL)) (EDITDATE? (CAR TAIL))) (/RPLACA TAIL (EDITDATE (CAR TAIL) INITIALS)) (RETURN T] (* scans the comments for a  timestamp for this user.) NIL) (T (* attach the new timestamp at the  beginning of the comments.) (/ATTACH (EDITDATE NIL INITIALS) E))) (RETURN EXPR]) (EDITDATE? [LAMBDA (COMMENT) (* ; "Edited 11-Jun-92 16:44 by cat") (* ; "Edited 13-Jul-89 09:30 by jtm:") (* lmm "21-Mar-85 08:45") (* Tests to see if a given common is in fact an edit date --  this has to be general enough to recognize the most comment comment forms while  specific enough to not recognize things that are not edit dates) (DECLARE (LOCALVARS . T)) (* jtm%: changed test so that it  creates one timestamp per user.) (COND [(LISTP COMMENT) (COND ((EQ (CAR COMMENT) COMMENTFLG) [COND (NIL (NULL NORMALCOMMENTSFLG) (SETQ COMMENT (GETCOMMENT COMMENT] (COND ([OR (NOT (LISTP (CDR COMMENT))) (NOT (LISTP (CDDR COMMENT] NIL) [(EQ (CADR COMMENT) ';) (* ; "CL style comment") (STRPOS INITIALS (CADDR COMMENT) (IMINUS (NCHARS INITIALS] (T (* ; "IL style comment") (EQ (CADR COMMENT) INITIALS] ((STRINGP COMMENT]) ) (* ; "Edit date support for all kinds of definers (from PARC 6/10/92)") (RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES)) (RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS) ) (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started." ) (DEFINEQ (FILEPKGCOM [LAMBDA N (* JonL "10-Jul-84 19:38") (PROG (TEM (COM (ARG N 1))) (RETURN (COND [(EQ N 1) (OR (for FIELD in '(MACRO CONTENTS DELETE ADD) when (SETQ TEM (FILEPKGCOM COM FIELD)) join (LIST FIELD TEM)) (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST)) (LIST 'COM T)) (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST] (LIST 'COM TEM] ((EQ N 2) (SELECTQ (ARG N 2) (ADD (fetch ADD of COM)) (DELETE (fetch DELETE of COM)) (MACRO (fetch MACRO of COM)) ((CONTENTS CONTAIN) [OR (fetch (FILEPKGCOM CONTENTS) of COM) (COND ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM)) (COND ((EQ COM 'NILL) COM) [(EQ (CAR COM) 'LAMBDA) (CONS (CAR COM) (CONS [CONS (CAADR COM) (CONS (OR (CADDR (CADR COM)) 'NAME) (CONS (CADR (CADR COM)) (CDDDR (CADR COM] (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM] (T (LIST 'LAMBDA '(COM TYPE NAME) (CONS COM '(COM TYPE NAME]) (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST)) T) (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]) (ERROR (ARG N 2) "not file package command property"))) (T [for I TEM2 from 2 to N by 2 do (SETQ TEM (ARG N (ADD1 I))) (COND [(EQ (ARG N I) 'COM) (SELECTQ TEM (NIL) (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST)) (/SETTOPVAL 'FILEPKGCOMSPLST (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]) (COND ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST] (/RPLACD TEM2 TEM)) (T (/SETTOPVAL 'FILEPKGCOMSPLST (CONS (CONS COM TEM) (GETTOPVAL 'FILEPKGCOMSPLST] (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST)) (/SETTOPVAL 'FILEPKGCOMSPLST (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST] (SELECTQ (ARG N I) (ADD (/replace (FILEPKGCOM ADD) of COM with TEM)) (DELETE (/replace (FILEPKGCOM DELETE) of COM with TEM)) (MACRO (/replace (FILEPKGCOM MACRO) of COM with TEM)) ((CONTENTS CONTAIN) (/replace (FILEPKGCOM CONTENTS) of COM with TEM)) (ERROR (ARG N I) "not file package command property"] (MARKASCHANGED COM 'FILEPKGCOMS]) (FILEPKGTYPE [LAMBDA N (* lmm " 5-Jul-85 09:07") (PROG ((TYPE (ARG N 1)) TEM) (RETURN (COND [(EQ N 1) (OR (for FIELD in (UNION '(DESCRIPTION) FILEPKGTYPEPROPS) when (SETQ TEM (FILEPKGTYPE TYPE FIELD)) join (LIST FIELD TEM)) (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES)) (LIST 'TYPE T)) (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES] (LIST 'TYPE TEM] [(EQ N 2) (if (FMEMB (ARG N 2) FILEPKGTYPEPROPS) then (GETPROP TYPE (ARG N 2)) else (SELECTQ (ARG N 2) (DESCRIPTION (fetch DESCRIPTION of TYPE)) (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES)) T) (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]) (ERROR (ARG N 2) "not file package type property"] (T [for I TEM2 from 2 to N by 2 do (SETQ TEM (ARG N (ADD1 I))) (COND [(EQ (ARG N I) 'TYPE) (SELECTQ TEM (NIL) (T (OR (FMEMB TYPE FILEPKGTYPES) (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES)))) (COND ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES)) (/RPLACD TEM2 TEM)) (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM) FILEPKGTYPES] (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES) (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES ] (if (FMEMB (ARG N I) FILEPKGTYPEPROPS) then (if TEM then (/PUTPROP TYPE (ARG N I) TEM) else (/REMPROP TYPE (ARG N I))) else (SELECTQ (ARG N I) (DESCRIPTION (/replace DESCRIPTION of TYPE with TEM)) (ERROR (ARG N I) "not file package command/type property" ] (MARKASCHANGED TYPE 'FILEPKGCOMS]) ) (PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS))) (ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS) (ADDTOVAR FILEPKGTYPES FILEPKGCOMS) (PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE) (* Revert to NILL when no longer coercing PRETTYDEFMACROS to FILEPKGCOMS) (AND (EQ TYPE 'FILEPKGCOMS) (INFILECOMTAIL COM] (TYPE DESCRIPTION "file package commands/types" GETDEF T PUTDEF FILEPKGCOMS.PUTDEF))) (PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X] (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF WHENCHANGED (ALISTS.WHENCHANGED)))) (PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X]) (PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS))) (PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED ( EXPRESSIONS.WHENCHANGED ) EDITDEF NILL))) (PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL))) (PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS) (TYPE TYPE FILEPKGCOMS))) (PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X] CONTENTS (LAMBDA (COM NAME TYPE) (AND (EQ TYPE 'FILES) (SUBSET (INFILECOMTAIL COM) (FUNCTION LITATOM] (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED) EDITDEF EDITDEF.FILES))) (PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X))) (TYPE NULLDEF NOBIND EDITDEF NILL))) (PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO (X [E (MAPC 'X (FUNCTION (LAMBDA (FN) (AND (GETPROP FN 'FUNCTIONS) (CL:WARN "~A has a FUNCTIONS definition" FN] (ORIGINAL (FNS . X))) CONTENTS NILL) (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF T))) (PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X))) CONTENTS (LAMBDA (COM NAME TYPE ONFILETYPE) (AND (NULL ONFILETYPE) (EQ TYPE 'RECORDS) (INFILECOMTAIL COM]) (PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T))) (PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS))) (PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X))) CONTENTS NILL) (TYPE DESCRIPTION "LISPX commands"))) (PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM MACRO [X (DECLARE%: EVAL@COMPILE (P * (MAPCAR 'X (FUNCTION (LAMBDA (Y) (LET [[FNDEF (GETDEF Y 'FUNCTIONS 'CURRENT '(NOCOPY NOERROR] (MACDEF (GETDEF Y 'MACROS 'CURRENT '(NOCOPY NOERROR] (COND ((AND FNDEF (EQ (CAR FNDEF) 'DEFMACRO)) (CL:WARN "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S." FNDEF) (LIST 'PROGN FNDEF MACDEF)) (T (OR MACDEF (CL:CERROR "Go ahead and finish writing out the file." "No MACROS definition for ~A." Y) (GETDEF Y 'MACROS 'CURRENT] CONTENTS NILL) (TYPE DESCRIPTION "Interlisp macros" GETDEF MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY)))) (PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS))) (PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X] (TYPE DESCRIPTION "property lists" WHENCHANGED ( PROPS.WHENCHANGED )))) (PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM MACRO (X [E (MAPC 'X (FUNCTION (LAMBDA (RECORD) (AND (GETPROP RECORD 'STRUCTURES) (CL:WARN "~A has a STRUCTURES definition" RECORD] (E (RECORDECLARATIONS . X)) (INITRECORDS . X)) CONTENTS (LAMBDA (COM NAME TYPE ONFILETYPE) (AND (EQ TYPE 'FIELDS) (NULL ONFILETYPE) (MAPCONC (INFILECOMTAIL COM) (FUNCTION (LAMBDA (X) (APPEND ( RECORDFIELDNAMES X] (TYPE DESCRIPTION "records" DELDEF (LAMBDA (X) (/SETTOPVAL 'USERRECLST (REMOVE (RECLOOK X) USERRECLST]) (PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T))) (PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X))) CONTENTS (LAMBDA (COM NAME TYPE ONFILETYPE) (AND (NULL ONFILETYPE) (EQ TYPE 'RECORDS) (INFILECOMTAIL COM]) (PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X))) CONTENTS NILL) (TYPE DESCRIPTION "edit macros"))) (PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X [E (MAPC 'X (FUNCTION (LAMBDA (VAR) (AND (GETPROP VAR 'VARIABLES) (CL:WARN "~A also has a VARIABLES definition" VAR] (ORIGINAL (VARS . X))) CONTENTS NILL) (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF VARS.PUTDEF))) (PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL))) (PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X) (P (CONSTANTS . X]) (ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS) (VARIABLES VARS CONSTANTS)) (RPAQ? SAVEDDEFS ) (* ; "EDITCALLERS") (DEFINEQ (FINDCALLERS [LAMBDA (ATOMS FILES) (* lmm "30-SEP-78 01:36") (PROG ((X (EDITCALLERS ATOMS FILES T))) (RETURN (NCONC (DREVERSE (CDR X)) (AND (CAR X) (LIST (CONS (COND ((CDR X) '"plus other places on") (T 'on)) (CAR X]) (EDITCALLERS [LAMBDA (ATOMS FILES COMS) (* ; "Edited 8-Aug-2020 17:32 by rmk:") (* bvm%: " 3-Nov-86 17:30") (LET (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN) [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS] [for FILE in (COND ((NULL FILES) FILELST) ((EQ FILES T) (UNION SYSFILES FILELST)) ((LISTP FILES) FILES) (T (LIST FILES))) do (RESETLST [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I) (OR (SETQ FULL (FINDFILE FILE)) (RETURN (LISPXPRINT (CONS FILE '(not found)) T T))) [RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT] (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM))) (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP) (OR (GET-ENVIRONMENT-AND-FILEMAP FULL) (\PARSE-FILE-HEADER FILESTREAM))) (* ;; "Get reader environment of file. The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists. Otherwise, read the top of the file") (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV))) (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL)) [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS))) (push FFILEPOSPATTERNS (CONS RDTBL (SETQ PATTERNS (for ATOM in ATOMS collect (CONCAT (COND ((EQ (CHCON1 ATOM) (CHARCODE ESCAPE)) (SETQ ATOM (SUBSTRING ATOM 2 -1)) "") (T " ")) [COND ((SETQ I (STRPOS ' ATOM)) (SUBSTRING ATOM 1 (SUB1 I))) ((STRINGP ATOM)) (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE ATOM))) (* ;  "Keep MKSTRING from putting a prefix on") (MKSTRING ATOM T RDTBL] (COND (I "") (T " "] (for PATTERN in PATTERNS do (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0))) (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA)) do (COND ((NULL PRINTFLG) (* ;  "cause the printing of the filename to be saved on history list") (SETQ PRINTFLG T) (LISPXPRIN2 FULL T T T) (* ;; "print with NODOFLG=T means just to record the printing; the idea is that only those files in which something is found will be remembered on the history list") (LISPXPRIN1 ": " T NIL T))) [OR [AND (NEQ MAP T) (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0) (SETQ MAP (OR (GETFILEMAP FILESTREAM) (LOADFILEMAP FILESTREAM] (PROGN (* ; "file has no filemap") (SETQ MAP (SETQ NOMAPFLG T)) (LISPXPRIN1 " no filemap!" T) NIL))) thereis (AND (ILESSP (CAR X) I) (IGREATERP (CADR X) I) (for Z in (CDDR X) thereis (COND ((AND (ILESSP (CADR Z) I) (IGREATERP (CDDR Z) I)) [COND ((NOT (FMEMB (CAR Z) FNS)) (SETQ FNS (CONS (LISPXPRIN2 (CAR Z) T T) FNS] (SETQ I (CDDR Z)) T] (PROGN (LISPXPRIN2 I T T) (OR (FMEMB FILE OTHERSFILES) (SETQ OTHERSFILES (CONS FILE OTHERSFILES] (LISPXSPACES 1 T))) (COND (PRINTFLG (LISPXTERPRI T)) (T (TERPRI T))) (COND ((NEQ COMS T) (COND ((OR FNS OTHERSFILES) (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS)) FULL EDITPATTERN COMS (NULL OTHERSFILES)) (SETQ OTHERSFILES) (SETQ FNS])] (COND ((EQ COMS T) (CONS OTHERSFILES FNS]) (EDITFROMFILE [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES) (* rmk%: "14-Mar-85 21:51") (RESETVARS [(EDITLOADFNSFLG (COND ((EQ EDITLOADFNSFLG T) '(T . NO)) (T EDITLOADFNSFLG] (PROG NIL [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN] (AND (SETQ FILES (for FILE inside (OR FILES FILELST) when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE) FILELST)) (COND ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" FILE) NIL T)) (LOADFROM FILE FNS 'ALLPROP) T))) collect FILE)) (for TYPE in [COND ((LISTP ONLYTYPES)) (ONLYTYPES '(FNS)) (T (* ;; "Move FNS to the front. This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.") (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES] when (AND (LITATOM TYPE) (NEQ (fetch EDITDEF of TYPE) 'NILL)) do (PROG (SEEN) (for FILE inside FILES do (for NAME in [COND ((AND (EQ TYPE 'FNS) (NEQ FNS T)) (* ;  "for this type, we are given the list of items") (PROG1 FNS (SETQ FNS NIL))) (T (* ;  "only want the values of `TYPE' which are not part of some other type") (FILECOMSLST FILE TYPE 'EDIT] unless (MEMBER NAME SEEN) do (ERSETQ (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT '(NOCOPY NOERROR)) (GETDEF NAME TYPE 'SAVED '(NOCOPY NOERROR] (* ;; "If definition has been loaded, it may have been editted. Work on that explicitly instead of bringing in a file definition to smash the users previous changes. Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS. --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file. But ... rmk") (COND ((OR (AND (EQ TYPE 'FNS) (NEQ FNS T)) (AND (LISTP DEF) (LOOKIN DEF EDITPATTERN))) (COND ((NULL SEEN) (LISPXPRIN1 "editing the " T) (LISPXPRIN1 (OR (fetch DESCRIPTION of TYPE) TYPE) T) (LISPXSPACES 1 T))) (SETQ SEEN (CONS NAME SEEN)) (LISPXPRIN2 NAME T T) (LISPXPRIN1 ": " T) (COND ((NOT (ERSETQ (EDITDEF NAME TYPE (OR (AND DEF (CONS '= DEF)) FILE) EDITCOMS))) (LISPXPRIN1 "failed" T))) (LISPXTERPRI T]) (FINDATS [LAMBDA (X L) (* lmm "11-FEB-78 16:03") (COND ((NLISTP X) (FMEMB X L)) (T (OR (FINDATS (CAR X) L) (FINDATS (CDR X) L]) (LOOKIN [LAMBDA (X PAT) (* lmm "11-MAR-78 14:20") (COND ([AND (EQ (CAR PAT) '*ANY*) (EVERY (CDR PAT) (FUNCTION (LAMBDA (X) (AND (LITATOM X) (NOT (STRPOS ' X] (FINDATS X (CDR PAT))) (T (EDITFINDP X PAT T]) ) (DEFINEQ (SEPRCASE [LAMBDA (CLFLG RDTBL) (* bvm%: "24-Oct-86 18:16") (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent. Based on FILERDTBL, but others are close with respect to breaks and seprs") (OR RDTBL (SETQ RDTBL FILERDTBL)) (OR [ARRAYP (CDR (ASSOC RDTBL (COND (CLFLG CLISPCASEARRAYS) (T SEPRCASEARRAYS] (LET ((CA (CASEARRAY))) [if (READTABLEPROP RDTBL 'CASEINSENSITIVE) then (* ; "map upper into lower case") (for I from (CHARCODE A) to (CHARCODE Z) do (SETCASEARRAY CA I (+ I (- (CHARCODE a) (CHARCODE A] (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS collect (CHCON1 Y))) (GETSEPR RDTBL) (GETBRK RDTBL)) do (SETCASEARRAY CA X 0)) (if *PACKAGE* then (* ;  "symbols qualified with package prefix will otherwise be unfindable") (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR) 0)) (SETQ CA (CONS RDTBL CA)) (COND (CLFLG (push CLISPCASEARRAYS CA)) (T (push SEPRCASEARRAYS CA))) (CDR CA]) ) (RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL)) (RPAQ? SEPRCASEARRAYS ) (RPAQ? CLISPCASEARRAYS ) (MOVD? 'INFILEP 'FINDFILE) (* ; "or else from SPELLFILE") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG) (NOLINKFNS LOADFROM)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS) ) (* ; "EXPORT") (DEFINEQ (IMPORTFILE [LAMBDA (FILE RETURNFLG) (* lmm " 6-Jun-86 17:43") (RESETLST [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT] (RESETSAVE (INPUT FILE)) (* ;  "Reset INPUT in case some form on the file's action is to read the next expression") (NCONC [COND ((EQ RETURNFLG T) (* ;  "Just creating EXPORTS.ALL, don't side-effect the world") (IMPORTFILESCAN FILE RETURNFLG)) (T (LET (FILEPKGFLG DFNFLG) (IMPORTFILESCAN FILE RETURNFLG] (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE)) ''IMPORTDATE (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE] RETURNFLG)))]) (IMPORTEVAL [LAMBDA (FORM RETURNFLG) (* ; "Edited 2-May-87 18:57 by Pavel") (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms") (AND (LISTP FORM) (SELECTQ (CAR FORM) (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG))) (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG))) (/DECLAREDATATYPE (* ;  "Ignore datatype initializations -- we only need the record declaration itself") NIL) (PROGN (* ; "default: eval and/or return it") (AND (NEQ RETURNFLG T) (EVAL FORM)) (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))))]) (CHECKIMPORTS [LAMBDA (FILES NOASKFLG) (* rmk%: "19-FEB-83 16:31") (* ;  "Loads exported definitions from new versions of FILES.") (COND ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE when [AND (SETQ FULLFILENAME (FINDFILE FILE T)) (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE) 'IMPORTDATE] (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 'ICREATIONDATE] collect (LIST FILE FULLFILENAME))) (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from " (MAPCAR FILES (FUNCTION CAR))) '((Y "es ") (N "o ")) T) (N NIL) T))) (for FILE in FILES do (IMPORTFILE (CADR FILE]) (GATHEREXPORTS [LAMBDA (FROMFILES TOFILE FLG) (* bvm%: "14-Oct-86 23:12") (* ;  "Copies all exported definitions from FROMFILES to TOFILE.") (RESETLST [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE) (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT] (RESETSAVE (OUTPUT TOFILE)) (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*)) (SETQ ENV (if ENV then (\DO-DEFINE-FILE-INFO NIL ENV) else *OLD-INTERLISP-READ-ENVIRONMENT*)) (WITH-READER-ENVIRONMENT ENV (PRINT-READER-ENVIRONMENT ENV) (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T) " ON " (DATE) "%" T)" T "(LISPXTERPRI T)" T) (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T)) (FUNCTION PRINT)) (TERPRI)) (PRINT 'STOP) (TERPRI) (FULLNAME TOFILE))))]) (\DUMPEXPORTS [NLAMBDA COMS (* bvm%: "24-Oct-86 19:42") (* ;;; "Dumps an EXPORT form. IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.") (PRIN1 "(") (PRIN2 '*) (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2)) (* ;  "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE") (for TAIL on COMS do (PRETTYCOM (CAR TAIL))) (TERPRI) (PRINT ENDEXPORTDEFFORM) (TERPRI]) ) (PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X]) (RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")") (RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM) ) (* ; "for GAINSPACE") (DEFINEQ (CLEARFILEPKG [LAMBDA (FLG) (* bvm%: "29-Aug-86 13:02") (PROG NIL (COND ((SELECTQ FLG ((E T) T) (Y (TERPRI T) (PRIN1 "you can delete just the filemaps - " T) (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? " '((Y "es - everything" RETURN T) (N "o - just the filemaps" RETURN NIL) (E "verything" RETURN T) (F "ilemaps only" RETURN NIL] (TERPRI T))) NIL) (UPDATEFILES) [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE) (COND ((fetch TOBEDUMPED of (fetch FILEPROP of FILE)) (PRINT FILE T T) (PRIN1 " has changes, not wiped." T) (TERPRI T) T) (T (replace FILEPROP of FILE with NIL) (replace FILECHANGES of FILE with NIL) (SMASHFILECOMS FILE) (NCONC1 SYSFILES FILE) NIL] (SETQ LOADEDFILELST))) (SELECTQ FLG ((NIL T)) (CLRHASH *FILEMAP-HASH*]) ) (ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE) ((Y "es") (N "o") (E . "verything") (F "ilemaps only ")))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SMASHPROPSLST1) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T) (SPECVARS COMSNAME)) (BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM (NOLINKFNS . T) (SPECVARS COMSNAME) (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1)) (BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG) INFILECOMSPROP) (BLOCK%: NIL MAKEFILE (LOCALVARS . T) (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES)) (BLOCK%: ADDFILE ADDFILE ADDFILE0) (BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T)) (BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS) (LOCALVARS . T)) (BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T)) (BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE GETDEFSAVED (RETFNS GETDEFCOM) (NOLINKFNS . T) (GLOBALVARS NOT-FOUNDTAG)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS PRETTYDEFMACROS) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES) ) (PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1995 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (22882 24587 (SEARCHPRETTYTYPELST 22892 . 23871) (PRETTYDEFMACROS 23873 . 24331) ( FILEPKGCOMPROPS 24333 . 24585)) (25389 59512 (CLEANUP 25399 . 26787) (COMPILEFILES 26789 . 27065) ( COMPILEFILES0 27067 . 27787) (CONTINUEDIT 27789 . 29209) (MAKEFILE 29211 . 40853) (FILECHANGES 40855 . 43190) (FILEPKG.MERGECHANGES 43192 . 44015) (FILEPKG.CHANGEDFNS 44017 . 44329) (MAKEFILE1 44331 . 48558) (COMPILE-FILE? 48560 . 50117) (MAKEFILES 50119 . 51812) (ADDFILE 51814 . 54335) (ADDFILE0 54337 . 58473) (LISTFILES 58475 . 59510)) (60200 95440 (FILEPKGCHANGES 60210 . 61560) (GETFILEPKGTYPE 61562 . 64635) (MARKASCHANGED 64637 . 66274) (FILECOMS 66276 . 66660) (WHEREIS 66662 . 68082) ( SMASHFILECOMS 68084 . 68319) (FILEFNSLST 68321 . 68483) (FILECOMSLST 68485 . 68969) (UPDATEFILES 68971 . 74271) (INFILECOMS? 74273 . 76176) (INFILECOMTAIL 76178 . 77318) (INFILECOMS 77320 . 77481) ( INFILECOM 77483 . 87692) (INFILECOMSVALS 87694 . 88021) (INFILECOMSVAL 88023 . 89025) (INFILECOMSPROP 89027 . 89856) (IFCPROPS 89858 . 91119) (IFCEXPRTYPE 91121 . 91632) (IFCPROPSCAN 91634 . 92687) ( IFCDECLARE 92689 . 94000) (INFILEPAIRS 94002 . 94334) (INFILECOMSMACRO 94336 . 95438)) (95475 126251 ( FILES? 95485 . 97678) (FILES?1 97680 . 98330) (FILES?PRINTLST 98332 . 99114) (ADDTOFILES? 99116 . 109718) (ADDTOFILE 109720 . 110636) (WHATIS 110638 . 112614) (ADDTOCOMS 112616 . 114260) (ADDTOCOM 114262 . 120809) (ADDTOCOM1 120811 . 121982) (ADDNEWCOM 121984 . 123034) (MAKENEWCOM 123036 . 124879) (DEFAULTMAKENEWCOM 124881 . 126249)) (126321 129138 (MERGEINSERT 126331 . 128674) (MERGEINSERT1 128676 . 129136)) (130657 141569 (DELFROMFILES 130667 . 131517) (DELFROMCOMS 131519 . 133198) (DELFROMCOM 133200 . 139068) (DELFROMCOM1 139070 . 139867) (REMOVEITEM 139869 . 140743) (MOVETOFILE 140745 . 141567)) (141783 144152 (SAVEPUT 141793 . 144150)) (144277 152601 (UNMARKASCHANGED 144287 . 145995) ( PREEDITFN 145997 . 148508) (POSTEDITPROPS 148510 . 151011) (POSTEDITALISTS 151013 . 152599)) (152750 173304 (ALISTS.GETDEF 152760 . 153139) (ALISTS.WHENCHANGED 153141 . 153785) (CLEARCLISPARRAY 153787 . 154961) (EXPRESSIONS.WHENCHANGED 154963 . 155337) (MAKEALISTCOMS 155339 . 156412) (MAKEFILESCOMS 156414 . 157851) (MAKELISPXMACROSCOMS 157853 . 159871) (MAKEPROPSCOMS 159873 . 160571) ( MAKEUSERMACROSCOMS 160573 . 162373) (PROPS.WHENCHANGED 162375 . 162996) (FILEGETDEF.LISPXMACROS 162998 . 164440) (FILEGETDEF.ALISTS 164442 . 165061) (FILEGETDEF.RECORDS 165063 . 165994) (FILEGETDEF.PROPS 165996 . 166788) (FILEGETDEF.MACROS 166790 . 167850) (FILEGETDEF.VARS 167852 . 168268) (FILEGETDEF.FNS 168270 . 169634) (FILEPKGCOMS.PUTDEF 169636 . 172076) (FILES.PUTDEF 172078 . 173035) (VARS.PUTDEF 173037 . 173180) (FILES.WHENCHANGED 173182 . 173302)) (175326 182759 (RENAME 175336 . 176737) ( CHANGECALLERS 176739 . 182757)) (182760 230708 (SHOWDEF 182770 . 183563) (COPYDEF 183565 . 186039) ( GETDEF 186041 . 188317) (GETDEFCOM 188319 . 189285) (GETDEFCOM0 189287 . 190633) (GETDEFCURRENT 190635 . 197055) (GETDEFERR 197057 . 198358) (GETDEFFROMFILE 198360 . 202640) (GETDEFSAVED 202642 . 203746) (PUTDEF 203748 . 204451) (EDITDEF 204453 . 205430) (DEFAULT.EDITDEF 205432 . 208268) (EDITDEF.FILES 208270 . 208471) (LOADDEF 208473 . 208649) (DWIMDEF 208651 . 209505) (DELDEF 209507 . 212521) ( DELFROMLIST 212523 . 213027) (HASDEF 213029 . 219351) (GETFILEDEF 219353 . 219875) (SAVEDEF 219877 . 221536) (UNSAVEDEF 221538 . 222434) (COMPAREDEFS 222436 . 225738) (COMPARE 225740 . 226444) (TYPESOF 226446 . 230706)) (230775 235818 (FIXEDITDATE 230785 . 234288) (EDITDATE? 234290 . 235816)) (236237 244823 (FILEPKGCOM 236247 . 241180) (FILEPKGTYPE 241182 . 244821)) (256860 271412 (FINDCALLERS 256870 . 257385) (EDITCALLERS 257387 . 265045) (EDITFROMFILE 265047 . 270727) (FINDATS 270729 . 271001) ( LOOKIN 271003 . 271410)) (271413 273140 (SEPRCASE 271423 . 273138)) (273657 279199 (IMPORTFILE 273667 . 274641) (IMPORTEVAL 274643 . 275523) (IMPORTFILESCAN 275525 . 275946) (CHECKIMPORTS 275948 . 277284 ) (GATHEREXPORTS 277286 . 278609) (\DUMPEXPORTS 278611 . 279197)) (279537 281745 (CLEARFILEPKG 279547 . 281743))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Feb-2021 17:16:04" {DSK}larry>ilisp>medley>sources>FILEPKG.;16 282953 changes to%: (VARS FILEPKGCOMS) (FNS ADDTOFILEKEYLST) previous date%: "27-Oct-2020 15:40:32" {DSK}larry>ilisp>medley>sources>FILEPKG.;15) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020, 2021 by Venue & Xerox Corporation. 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 FILEPKGCOMS) (RPAQQ FILEPKGCOMS [(COMS (* ;  "standard records for accessing file package type/command parts. Exported for PRETTY") (VARS FILEPKGTYPEPROPS) (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS))) (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS) (INITRECORDS * FILEPKGRECORDS)) [DECLARE%: EVAL@COMPILE DOCOPY (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.") (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG)) (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS] (INITVARS (MSDATABASELST)) [COMS (* ;; "making, adding, listing, compiling files") (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE ADDFILE0 LISTFILES) (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE) (FILELST) (LOADEDFILELST) (NOTLISTEDFILES) (NOTCOMPILEDFILES) (MAKEFILEFORMS) (NILCOMS)) (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% F ST STF (REC . RC) (BREC . RC) (TC . C) (BC . C) (TCOMPL . C) (BCOMPL . C))) (INITVARS (MAKEFILEREMAKEFLG T) (CLEANUPOPTIONS '(RC] (COMS (* ;; "scanning file coms") (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE INFILEPAIRS INFILECOMSMACRO)) (COMS (* ;; "adding to a file") (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM) (INITVARS (DEFAULTCOMHASFILEFLG)) (ADDVARS (MARKASCHANGEDFNS)) (FNS MERGEINSERT MERGEINSERT1) (* ;; "RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file") (FNS ADDTOFILEKEYLST) (INITVARS (ADDTOFILEKEYLST (ADDTOFILEKEYLST)) (LASTFILE))) (COMS (* ;; "deleting an item from a file") (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE) (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T) (MOVD? 'MOVETOFILE 'MOVEITEM NIL T)) (ADDVARS (SYSPROPS PROPTYPE VARTYPE))) [COMS (* ;  "functions for doing things and marking them changed and auxiliary functions") (FNS SAVEPUT) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT) (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT] (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS) (ADDVARS (LISPXFNS (PUT . SAVEPUT) (PUTPROP . SAVEPUT] (COMS (* ;  "sub-functions for file package commands & types") (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED) (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO) (SYSPROPS PROPTYPE)) (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT FILETYPE) (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS PRETTYPRINTYPEMACROS USERMACROS)) (COMS (* ;  "Define the commands below AFTER the various properties have been established.") (USERMACROS M)) (COMS (* ; "GETDEF methods") (FNS RENAME CHANGECALLERS) (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF) (INITVARS (WHEREIS.HASH))) (* ; "Must come after PUTDEF") (FNS FIXEDITDATE EDITDATE?) (* ;  "Edit date support for all kinds of definers (from PARC 6/10/92)") [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES)) (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES] (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS) (COMS (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.") (FNS FILEPKGCOM FILEPKGTYPE) (PROP ARGNAMES FILEPKGCOM) (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS) (FILEPKGTYPES FILEPKGCOMS)) (FILEPKGCOMS FILEPKGCOMS) (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS)) (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS) (VARIABLES VARS CONSTANTS))) (INITVARS (SAVEDDEFS)) (COMS (* ; "EDITCALLERS") (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN) (FNS SEPRCASE) [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL] (INITVARS (SEPRCASEARRAYS) (CLISPCASEARRAYS)) (P (MOVD? 'INFILEP 'FINDFILE) (* ; "or else from SPELLFILE")) (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG) (NOLINKFNS LOADFROM))) (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)) (COMS (* ; "EXPORT") (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS) (FILEPKGCOMS EXPORT) [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")") (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"] (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)) (COMS (* ; "for GAINSPACE") (FNS CLEARFILEPKG) [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE) ((Y "es") (N "o") (E . "verything") (F "ilemaps only "] (GLOBALVARS SMASHPROPSLST1)) (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS) (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T) (SPECVARS COMSNAME)) (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM (NOLINKFNS . T) (SPECVARS COMSNAME) (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1)) (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG) INFILECOMSPROP) (NIL MAKEFILE (LOCALVARS . T) (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES)) (ADDFILE ADDFILE ADDFILE0) (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T)) (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS) (LOCALVARS . T)) (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T)) (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE GETDEFSAVED (RETFNS GETDEFCOM) (NOLINKFNS . T) (GLOBALVARS NOT-FOUNDTAG))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS PRETTYDEFMACROS) (NLAML) (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES]) (* ; "standard records for accessing file package type/command parts. Exported for PRETTY") (RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED HASDEF EDITDEF CANFILEDEF FILEGETDEF)) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP)) (DECLARE%: EVAL@COMPILE (ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE)) (T (/REMPROP DATUM 'ADDTOPRETTYCOM] [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE)) (T (/REMPROP DATUM 'DELFROMPRETTYCOM] [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE)) (T (/REMPROP DATUM 'PRETTYTYPE] [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE)) (T (/REMPROP DATUM 'FILEPKGCONTENTS] (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS] (STANDARD [COND [NEWVALUE (PUTASSOC DATUM NEWVALUE (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS)) (SETTOPVAL 'PRETTYDEFMACROS (LIST (LIST DATUM] (T (SETTOPVAL 'PRETTYDEFMACROS (REMOVE (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS)) (GETTOPVAL 'PRETTYDEFMACROS] UNDOABLE (COND [NEWVALUE (/PUTASSOC DATUM NEWVALUE (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS)) (/SETTOPVAL 'PRETTYDEFMACROS (LIST (LIST DATUM] (T (/SETTOPVAL 'PRETTYDEFMACROS (REMOVE (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS)) (GETTOPVAL 'PRETTYDEFMACROS] (* Not an atom record cause want  REMPROP on NILs.) (* NOTE%: PRETTCOM on PRETTY has  open-coded access to the MACRO  property.) (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS))) (ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED HASDEF EDITDEF FILEGETDEF CANFILEDEF) (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM)) (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE)) ) (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST DATUM))) (STANDARD (SETTOPVAL (CAR ( SEARCHPRETTYTYPELST DATUM NEWVALUE) ) NEWVALUE) UNDOABLE (/SETTOPVAL (CAR ( SEARCHPRETTYTYPELST DATUM NEWVALUE)) NEWVALUE))) (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST DATUM))) (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST DATUM NEWVALUE)) NEWVALUE))) (ALLFIELDS NIL (/SETTOPVAL 'PRETTYTYPELST (REMOVE (SEARCHPRETTYTYPELST DATUM) (GETTOPVAL 'PRETTYTYPELST] (* NOTE%: PRETTYCOM on PRETTY has  open-coded access to GETDEF property) (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS)) (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X) (PUT X 'PROPTYPE 'FILEPKGCOMS] (ADDTOVAR PRETTYTYPELST )))) (ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP) [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE) (STANDARD (PUTPROP DATUM 'FILE NEWVALUE) UNDOABLE (/PUTPROP DATUM 'FILE NEWVALUE]) (RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME)) (RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED)) ) (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS) [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS)) (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X) (PUT X 'PROPTYPE 'FILEPKGCOMS] (ADDTOVAR PRETTYTYPELST ) ) (* "END EXPORTED DEFINITIONS") (DEFINEQ (SEARCHPRETTYTYPELST [LAMBDA (TYPE FLG) (* rmk%: " 3-JAN-82 22:55") (* ;  "access functions used by the records") (AND (LITATOM TYPE) (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X) TYPE)) (COND (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE 'LST) TYPE NIL)) (GETTOPVAL 'PRETTYTYPELST] (OR (LISTP (GETTOPVAL (CAR FLG))) (/SETTOPVAL (CAR FLG) NIL)) FLG]) (PRETTYDEFMACROS [NLAMBDA ARGS (* lmm " 5-SEP-78 16:16") (* ;  "included so that old files will continue to load") (for X in ARGS collect (FILEPKGCOM (CAR X) 'MACRO (CDR X]) (FILEPKGCOMPROPS [NLAMBDA PROPS (MAPC PROPS (FUNCTION (LAMBDA (Y) (OR (MEMB Y SYSPROPS) (SETQ SYSPROPS (CONS Y SYSPROPS))) (PUT Y 'PROPTYPE 'FILEPKGCOMS]) ) (RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP)) (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS) [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS)) (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X) (PUT X 'PROPTYPE 'FILEPKGCOMS] (ADDTOVAR PRETTYTYPELST ) (DECLARE%: EVAL@COMPILE DOCOPY (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG)) (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS)) ) (RPAQ? MSDATABASELST ) (* ;; "making, adding, listing, compiling files") (DEFINEQ (CLEANUP [NLAMBDA FILES (* lmm "14-Aug-84 19:17") (PROG (TEM1 TEM2 OPTIONS) (COND ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES] (SETQ OPTIONS (CAR FILES)) (SETQ FILES (CDR FILES))) (T (SETQ OPTIONS CLEANUPOPTIONS))) (RETURN (APPEND (MAKEFILES OPTIONS FILES) (COND ((NOT (MEMB 'LIST OPTIONS)) NIL) ((NULL FILES) (LISTFILES)) ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES)) (* ;  "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.") (APPLY 'LISTFILES TEM1))) (COND [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS] ((NULL FILES) (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES) (CDR TEM1)) TEM2) ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES)) (COMPILEFILES0 TEM2 (CDR TEM1)) TEM2]) (COMPILEFILES [NLAMBDA FILES (* lmm "14-Aug-84 19:17") (COND ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES] (COMPILEFILES0 (CDR FILES) (CAR FILES))) (T (COMPILEFILES0 FILES]) (COMPILEFILES0 [LAMBDA (FILES OPTIONS) (* rmk%: "19-FEB-83 21:59") (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES) first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS)) (C (SETQ RCFLG NIL) (CDR OPTIONS)) (RC (CDR OPTIONS)) OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X) 70 FILELST NIL X) (CAR X)) RCFLG OPTS X]) (CONTINUEDIT [LAMBDA (FILE) (* bvm%: "30-Aug-86 15:09") (PROG (STREAM FL TEM FC ENV) (RESETLST [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT] (SETQ FILE (FULLNAME STREAM)) (SETFILEPTR STREAM 0) (CL:MULTIPLE-VALUE-SETQ (ENV FC) (\PARSE-FILE-HEADER STREAM 'RETURN))) (COND ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE] (LOADFROM FILE) (* ;  "also calls addfile to notice the file.") )) (/replace FILECHANGES of FL with (FILECHANGES FC)) [/replace FILEDATES of FL with (LIST (create FILEDATEPAIR FILEDATE _ (CADR FC) DATEFILENAME _ FILE) (create FILEDATEPAIR FILEDATE _ [CAR (SETQ TEM (CDR (MEMB 'date%: FC] DATEFILENAME _ (CADR TEM] (RETURN FILE]) (MAKEFILE [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE) (* ; "Edited 29-Aug-89 11:46 by bvm") (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL; LIST means list the FILE; RC means RECOMPILE, C means COMPILEL; --- for C AND RC assume ST unless next option is F.") (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS] PRETTYFLG)) (*PRINT-BASE* (if (EQ *PRINT-BASE* 8) then 8 else (* ; "make sure radix is either 8 or 10, because all others don't read in like they print. Maybe obsolete now with makefile environments") 10)) FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE))) (DECLARE (CL:SPECIAL PRETTYFLG)) (SETQ FILE (CAR Z)) (* ;  "Necessary because FILE might have been misspelled.") (SETQ ROOTNAME (CADR Z)) (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.") (SETQ FILEPROP (CDDR Z)) (UPDATEFILES) (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.") (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP)) (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME))) (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE)) LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP)) (NULL FILEDATES)) then (* ;  "File has never been loaded and never dumped i.e. user just set up COMS in core") elseif [OR (EQMEMB 'NEW OPTIONS) (AND (NULL MAKEFILEREMAKEFLG) (NOT (MEMB 'REMAKE OPTIONS] then (COND ((AND (fetch LOADTYPE of FILEPROP) (NEQ T (fetch LOADTYPE of FILEPROP))) (LISPXPRIN2 FILE T T) (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP) (LOADCOMP "the file was loaded for compilation purposes only") ((compiled Compiled COMPILED) " -- only the compiled file has been loaded ") ((loadfns LOADFNS) " -- only some of its symbolics have been loaded ") (SHOULDNT)) T) (COND ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ") 'Y) (* ;  "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.") (GO OUT))) (/replace LOADTYPE of FILEPROP with NIL))) (SETQ SOURCEFILE NIL) (SETQ REPRINTFNS NIL) elseif SOURCEFILE then (* ; "source file given") elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T)) (EQUAL (FILEDATE SOURCEFILE) (fetch FILEDATE of (CAR FILEDATES] (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE (fetch DATEFILENAME of (CAR FILEDATES ] (INFILEP SOURCEFILE) (EQUAL (FILEDATE SOURCEFILE) (fetch FILEDATE of (CAR FILEDATES] then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE) (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))) elseif [AND (CDR FILEDATES) [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES] (EQUAL (FILEDATE SOURCEFILE) (fetch FILEDATE of (CADR FILEDATES] then (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.") (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP) (fetch FILECHANGES of ROOTNAME))) (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)) else (LISPXPRIN1 '"can't find either the previous version or the original version of " T) (LISPXPRIN2 FILE T T) (LISPXPRIN1 '", so it will have to be written anew " T) (SETQ SOURCEFILE NIL) (SETQ REPRINTFNS NIL) (push OPTIONS 'NEW) (SETQ CHANGES (fetch FILECHANGES of ROOTNAME)) (GO LP0)) (COND ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP) (LOADCOMP (* ;  "only loaded via LOADCOMP. Need to do LOADFROM") (LIST 'N SOURCEFILE "was loaded with LOADCOMP" '- "LOADFROM it to obtain VARS/COMS")) (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%: (fetch COMSNAME of FILEPROP)) (LIST 'Y "only compiled version of" ROOTNAME "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions" ))) ((compiled loadfns) (LIST 'N "Only some functions from" SOURCEFILE "loaded via LOADFNS. Load all other expressions from it" )) NIL))) (SELECTQ [ASKUSER DWIMWAIT (CAR Z) (CDR Z) '((Y "es ") (N "o ") (A "bort MAKEFILE "] (Y (SELECTQ (fetch LOADTYPE of FILEPROP) (LOADCOMP (* ;  "file was never actually loaded, just loadcomped. thus no filecoms") (LOADFROM SOURCEFILE)) (Compiled (* ;; "This is going to be a remake. If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.") (LOADVARS 'DONTCOPY SOURCEFILE) (/replace LOADTYPE of FILEPROP with 'COMPILED) (* ; "So wont have to be done again.") (* ;; "These are the only DECLARE:'s that are not also on the compiled file. Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE: Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)") ) ((loadfns compiled) (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.") (LOADVARS T SOURCEFILE)) NIL)) (A (GO OUT)) NIL))) (RESETLST [COND ((MEMB 'NOCLISP OPTIONS) (RESETSAVE PRETTYTRANFLG T)) ((MEMB 'CLISP% OPTIONS) (RESETSAVE PRETTYTRANFLG 'BOTH] (RESETSAVE %#UNDOSAVES) [COND ((OR (MEMB 'CLISPIFY OPTIONS) (MEMB 'CLISP OPTIONS)) (RESETSAVE CLISPIFYPRETTYFLG T)) ((OR (EQ FILETYPE 'CLISP) (MEMB 'CLISP (LISTP FILETYPE))) (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES] (for X in MAKEFILEFORMS do (ERSETQ (EVAL X))) (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP) REPRINTFNS SOURCEFILE CHANGES))) (SETQ LASTFILE ROOTNAME) (/replace TOBEDUMPED of FILEPROP with NIL) (COND ((NOT (EQMEMB 'DON'TLIST FILETYPE)) (pushnew NOTLISTEDFILES ROOTNAME))) (COND ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE)) (pushnew NOTCOMPILEDFILES ROOTNAME))) [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL)) (SELECTQ OPT (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES) (MAKEFILE1 FILE T (CDR TAIL)))) (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES) (MAKEFILE1 FILE NIL (CDR TAIL)))) (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES) (APPLY 'LISTFILES (LIST FILE)))) (COND ((MEMB OPT MAKEFILEOPTIONS)) ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL OPTIONS) (GO $$LP)) (T (ERROR "Unrecognized MAKEFILE option" OPT] (RETURN FILE) OUT (RETURN (LIST FILE "-- MAKEFILE not performed."]) (FILECHANGES [LAMBDA (FILE TYPE) (* bvm%: "30-Aug-86 15:08") (* ;; "If FILE is a list, it is assumed to be a file-created expressions; otherwise, the filecreated expression is read from FILE. If TYPE, returns the list of changed items of that type from the changes expression. If TYPE=NIL, returns the whole list of typed change-lists") (PROG ([FCEXPR (OR (LISTP FILE) (AND FILE (RESETLST (LET (OLDPTR STREAM) [if (SETQ STREAM (OPENP FILE 'INPUT)) then (SETQ OLDPTR (GETFILEPTR STREAM)) (SETFILEPTR STREAM 0) else (RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT] (CL:MULTIPLE-VALUE-BIND (ENV FC) (\PARSE-FILE-HEADER STREAM 'RETURN) (if OLDPTR then (SETFILEPTR STREAM OLDPTR)) FC)))] FNS CHANGES) (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR))) (MEMB 'previous CHANGES))) [if (AND TYPE (NEQ TYPE 'FNS)) then (RETURN (CDR (ASSOC TYPE CHANGES] (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM))) (* ;  "Old style changes expression listed FNS by name and other things by type") (RETURN (if TYPE then (* ; "TYPE=FNS cause of test above.") (NCONC FNS (CDR (ASSOC 'FNS CHANGES))) elseif FNS then (CONS (CONS 'FNS FNS) (SUBSET CHANGES (FUNCTION LISTP))) else CHANGES]) (FILEPKG.MERGECHANGES [LAMBDA (C1 C2) (* rmk%: "24-MAY-82 23:09") (* ;; "Merges 2 changes lists into a single one. Treat LITATOM's as FNS, to accomodate old-style format on files.") (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND E1))) in C2 do [COND ((SETQ TEMP (ASSOC (CAR E2) VAL)) (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP)) collect X))) (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL]) (FILEPKG.CHANGEDFNS [LAMBDA (CHANGES) (* rmk%: "20-MAY-82 22:00") (* ;; "Returns list of function names from a file-changes list. Interprets old format (functions are atoms) and new format (with explicit type headers)") (CDR (ASSOC 'FNS CHANGES]) (MAKEFILE1 [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES) (* ; "Edited 27-Oct-2020 15:40 by rmk:") (* ; "Edited 29-Aug-89 11:46 by bvm") (* ;; "RMK: Call COMPILE-FILE? with FILE instead of (ROOTFILENAME FILE)") (PROG ((ROOTNAME (ROOTFILENAME FILE)) (COMPILER (COMPILE-FILE? FILE)) GROUP) (COND ((AND (OR (EQ COMPILER 'BCOMPL) (EQ COMPILER 'TCOMPL)) (NOT (FILEFNSLST ROOTNAME))) (* ;  "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.") (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES)) (RETURN NIL))) (COND ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP)) suchthat (AND (NEQ X ROOTNAME) (OR (fetch TOBEDUMPED of (fetch FILEPROP of X)) (MEMB X OTHERFILES] (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled. Wait.") (RETURN))) (LISPXPRIN1 '" compiling " T) (LISPXPRINT (OR GROUP FILE) T T) (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS) 'ST) (EQ (CAR OPTIONS) 'STF] (FORGET-EXPRS? (EQ (CAR OPTIONS) 'STF] (SELECTQ COMPILER ((FAKE-COMPILE-FILE) (* ;  "The old CommonLispy interface to the ByteCompiler.") (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS (AND REDEFINE? (NOT FORGET-EXPRS?)))) ((CL:COMPILE-FILE) (* ; "The new, improved (?) compiler") (CL:COMPILE-FILE FILE :LOAD (COND ((AND REDEFINE? (NOT FORGET-EXPRS? )) :SAVE) (REDEFINE? T) (T NIL)))) ((TCOMPL BCOMPL) (* ; "The old ByteCompiler") [IF (MEMB (CAR OPTIONS) '(ST F S STF)) THEN (LISPXUNREAD (LIST (CAR OPTIONS] [IF GROUP THEN (* ;;  "File contained in FILEGROUP. Therefore must be blockcompiled.") (IF RECOMPFLG THEN (BRECOMPILE GROUP) ELSE (BCOMPL GROUP)) ELSEIF (EQ COMPILER 'TCOMPL) THEN (IF RECOMPFLG THEN (RECOMPILE FILE) ELSE (TCOMPL (LIST FILE))) ELSE (IF RECOMPFLG THEN (BRECOMPILE FILE) ELSE (BCOMPL (LIST FILE]) (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?..."))) T T]) (COMPILE-FILE? [LAMBDA (FILE) (* ; "Edited 27-Oct-2020 15:39 by rmk:") (* ; "Edited 19-Jan-87 21:12 by Pavel") (* ;; "RMK: Argument is FILE instead of ROOTFILENAME, maybe more information") (* ;;; "Which compiler should CLEANUP use?") (LET ((TYPE (GET (ROOTFILENAME FILE) 'FILETYPE)) (UNKNOWN NIL)) (FOR X INSIDE TYPE DO (SELECTQ X ((TCOMPL :TCOMPL) (RETURN 'TCOMPL)) ((BCOMPL :BCOMPL) (RETURN 'BCOMPL)) ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) (RETURN 'FAKE-COMPILE-FILE)) ((:COMPILE-FILE :XCL-COMPILE-FILE) (RETURN 'CL:COMPILE-FILE)) ((CLISP) NIL) (SETQ UNKNOWN T)) FINALLY (IF UNKNOWN THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE )) (RETURN *DEFAULT-CLEANUP-COMPILER*]) (MAKEFILES [LAMBDA (OPTIONS FILES) (* rmk%: "23-FEB-83 21:20") (RESETVARS (%#UNDOSAVES) (* ;  "Willing to save arbitrary amounts of undo info") (UPDATEFILES) [COND ((NULL FILES) (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE (COND ((NULL FLG) (* ; "Gets printed the first time") ' "****NOTE: the following are not contained on any file: ") (T '" "] do (SETQ FLG T) finally (AND FLG (ADDTOFILES?] (SETQ OPTIONS (MKLIST OPTIONS)) (RETURN (for FILE inside (OR FILES FILELST) when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP of (ROOTFILENAME FILE] collect (LISPXPRIN2 FILE T T) (LISPXPRIN1 '|...| T) (PROG1 (MAKEFILE FILE OPTIONS) (LISPXTERPRI T]) (ADDFILE [LAMBDA (FILE LOADTYPE PRLST FCLST) (* bvm%: "29-Aug-86 12:22") (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.") (PROG ((ROOTNAME (ROOTFILENAME FILE)) FLST VAL) [COND ((NOT FCLST) (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE))) [(NULL (CDR FCLST)) (* ; "A simple symbolic file") (SETQ FCLST (CAR FCLST)) (SETQ VAL (ADDFILE0 (COND ((LITATOM (CADR FCLST)) (ROOTFILENAME (CADR FCLST))) (T ROOTNAME)) LOADTYPE FILE (CAR FCLST] (T (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.") (SELECTQ LOADTYPE ((T LOADFNS) (SETQ LOADTYPE 'Compiled)) (loadfns (SETQ LOADTYPE 'compiled)) (LOADCOMP (* ;  "loadcomp on compiled file. Don't notice since we don't know what its state is") NIL) (SHOULDNT)) (for X in (CDR FCLST) when (LITATOM (CADR X)) do (push FLST (CADR X)) (OR (EQ LOADTYPE 'LOADCOMP) (ADDFILE0 (ROOTFILENAME (CADR X)) LOADTYPE (CADR X) (CAR X] (UPDATEFILES PRLST (OR FLST (LIST FILE))) [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES when (AND (LITATOM TYPE) (SETQ CHANGED (fetch CHANGED of TYPE))) do (/replace CHANGED of TYPE with (INTERSECTION (CDR (ASSOC TYPE PRLST)) CHANGED] (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS)) (RETURN VAL]) (ADDFILE0 [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT) (* lmm "28-Nov-84 16:47") (PROG (COMS X FILEPROP FLG TEM) TOP (SETQ COMS (FILECOMS ROOTNAME)) [COND ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME)) (COND ([AND LOADTYPE (FMEMB LOADTYPE (CDR (FMEMB (fetch LOADTYPE of FILEPROP) '(LOADCOMP loadfns compiled Compiled LOADFNS COMPILED NIL T] (/replace LOADTYPE of FILEPROP with LOADTYPE) (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property. 'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file. 'Compiled' means all but DECLARE: expressions are in. e.g. user does LOAD of a compiled file. COMPILED means everything is in, e.g. user does LOADDFROM a compiled file. LOADFNS means everything in, e.g. user des LOADFROM symbolic file. COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted. NIL is a makefile when coms were set up in core. T is full load of symbolic file. The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.") (* ;; "LOADCOMP means file was loadcomp'ed. note that the actual structure is a tree, not a list, and the above is only an approximation. if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc. however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.") (GO OUT)) (T (GO OUT1] (COND [(OR LOADTYPE (LISTP (GETTOPVAL COMS))) (SETQ FILEPROP (/replace FILEPROP of ROOTNAME with (create FILEPROP COMSNAME _ COMS LOADTYPE _ LOADTYPE] (FLG (GO ERROR)) ((AND DWIMFLG (EQ ROOTNAME FULLNAME) (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T))) (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.") (SETQ FULLNAME ROOTNAME) (SETQ FLG T) (* ;  "so wont try to spelling correct again if file isnt there") (GO TOP)) (T (GO ERROR))) OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME with (LIST (create FILEDATEPAIR FILEDATE _ DAT DATEFILENAME _ FULLNAME] (AND (EQ LOADTYPE T) (/replace TOBEDUMPED of FILEPROP with NIL)) OUT1 [COND ([AND (LISTP (GETTOPVAL COMS)) (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ;  "coms wuld not be set up on a loadccomp.") (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST] (RETURN (COND ((NULL LOADTYPE) (* ; "call from makefile.") (CONS FULLNAME (CONS ROOTNAME FILEPROP))) (T FILEPROP))) ERROR (ERROR FULLNAME "not file name." T]) (LISTFILES [NLAMBDA FILES (* rmk%: " 3-Dec-84 08:58") (DECLARE (GLOBALVARS NOTLISTEDFILES)) (* ; "LISTFILES1 is machinedependent") (for FILE FULLNAME OPTIONS in (COND (FILES (SETQ FILES (NLAMBDA.ARGS FILES))) (T NOTLISTEDFILES)) when (COND ((LISTP FILE) (SETQ OPTIONS (APPEND FILE OPTIONS)) NIL) ((SETQ FULLNAME (FINDFILE FILE)) FULLNAME) (T (printout T FILE " not found." T) NIL)) collect [COND ((LISTFILES1 FULLNAME OPTIONS) (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T) NOTLISTEDFILES] FULLNAME]) ) (RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE) (RPAQ? FILELST ) (RPAQ? LOADEDFILELST ) (RPAQ? NOTLISTEDFILES ) (RPAQ? NOTCOMPILEDFILES ) (RPAQ? MAKEFILEFORMS ) (RPAQ? NILCOMS ) (ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% F ST STF (REC . RC) (BREC . RC) (TC . C) (BC . C) (TCOMPL . C) (BCOMPL . C)) (RPAQ? MAKEFILEREMAKEFLG T) (RPAQ? CLEANUPOPTIONS '(RC)) (* ;; "scanning file coms") (DEFINEQ (FILEPKGCHANGES [LAMBDA N (* Pavel " 7-Oct-86 19:22") (COND [(EQ N 0) (PROG (TEM) (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X) (SETQ TEM (FILEPKGCHANGES X))) collect (CONS X TEM] [(EQ (ARG N 1) T) (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES X] [(EQ N 1) (COND [(LISTP (ARG N 1)) (for X in (ARG N 1) when (FMEMB (CAR X) FILEPKGTYPES) do (/replace CHANGED of (CAR X) with (CDR X] (T (for Y on (fetch CHANGED of (ARG N 1)) when [AND (CAR Y) (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y) Z] collect (CAR Y] (T (/replace CHANGED of (ARG N 1) with (ARG N 2]) (GETFILEPKGTYPE [LAMBDA (TYPE ONLY NOERROR NAME) (* lmm "20-Nov-86 23:10") (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ") (COND [(LISTP TYPE) (* ;; " given a list of types, coerce them all or return NIL") (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME) (RETURN] ((EQ TYPE '?) (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ") (AND NAME (TYPESOF NAME))) [(AND (NEQ ONLY 'COMS) (OR (SELECTQ TYPE (NIL 'FNS) (T 'VARS) NIL) (for X in FILEPKGTYPES do (if (EQ TYPE X) then (* ;; "type matched exactly") (RETURN TYPE) elseif (AND (LISTP X) (EQ TYPE (CAR X))) then (RETURN (CDR X] [(AND (NEQ ONLY 'TYPE) (LITATOM TYPE) (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST)) (* ; "Prefer an exact match quickly") ] [(AND (NEQ ONLY 'COMS) (LITATOM TYPE) (for X in FILEPKGTYPES bind NAME do (SETQ NAME (if (NLISTP X) then X else (CAR X))) (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization") (AND (<= 0 (- (NCHARS NAME) (NCHARS TYPE)) 1) (STRPOS TYPE NAME) (RETURN (if (EQ X NAME) then X else (CDR X] [(FIXSPELL TYPE NIL (SELECTQ ONLY (TYPE FILEPKGTYPES) (COMS FILEPKGCOMSPLST) (UNION FILEPKGTYPES FILEPKGCOMSPLST] ((NOT NOERROR) (ERROR (SELECTQ ONLY (TYPE "unrecognized manager definition type") (COMS "unrecognized manager command") "unrecognized manager definition-type/command") TYPE]) (MARKASCHANGED [LAMBDA (NAME TYPE REASON) (* ; "Edited 25-May-88 15:37 by drc:") (COND (FILEPKGFLG (SETQ REASON (SELECTQ REASON ((CLISP LOAD CHANGED DEFINED DELETED) REASON) (NIL 'CHANGED) (T 'DEFINED) (ERROR "bad REASON in MARKASCHANGED" REASON))) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (for FN inside (fetch WHENCHANGED of TYPE) do (APPLY* FN NAME TYPE REASON)) (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON)) [COND ((EQ REASON 'DELETED) (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L) NAME) do (/RPLACA L NIL)) (* ;  "unmark as changed and remove from files") (DELFROMFILES NAME TYPE)) (T (LET ((LST (push (fetch CHANGED of TYPE) NAME))) (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST) LISPXHIST)) (* ;  "UNDO by smashing with NIL; makes calls to MARKASCHANGED independent") ] NAME]) (FILECOMS [LAMBDA (FILE X) (* rmk%: "19-FEB-83 13:55") (COND ((AND (NULL FILE) (NULL X)) 'NILCOMS) [(AND (OR (NULL X) (EQ X 'COMS)) (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE] (T (PACK* (NAMEFIELD FILE) (OR X 'COMS]) (WHEREIS [LAMBDA (NAME TYPE FILES FN) (* ; "Edited 12-Jul-88 17:14 by MASINTER") (* ;; "T as a NAME has a special meaning to INFILECOMS? so don't pass through.") (CL:UNLESS (EQ NAME T) (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES) FILELST) (FUNCTION (LAMBDA (FILE) (INFILECOMS? NAME TYPE (FILECOMS FILE] (AND (EQ FILES T) (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS) (LET ((FILES NIL)) (for TY inside TYPE do (for FILE-NAME in (XCL::HASH-FILE-WHERE-IS NAME (GETFILEPKGTYPE TYPE)) do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME)) FILES))) (REVERSE FILES] (CL:IF FN [MAPC IN-FILES (FUNCTION (LAMBDA (FILE) (APPLY* FN NAME FILE] IN-FILES)))]) (SMASHFILECOMS [LAMBDA (FILE) (* rmk%: "19-FEB-83 22:15") (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X) do (SETTOPVAL X 'NOBIND)) FILE]) (FILEFNSLST [LAMBDA (FILE) (* ; "Edited 14-Jun-90 19:30 by jds") (FILECOMSLST FILE '(FUNCTIONS FNS]) (FILECOMSLST [LAMBDA (FILE TYPE FLG) (* JonL "24-Jul-84 19:48") (* ;  "TYPE is coerced in the innards of INFILECOMS?") (COND ((EQ FLG 'UPDATE) (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE) FLG))) (T (INFILECOMS? NIL TYPE (FILECOMS FILE) FLG]) (UPDATEFILES [LAMBDA (PRLST FLST) (* rmk%: "19-FEB-83 14:27") (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g. LOAD, LOADFNS) involving the files in FLST began.") (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE)) do (COND ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE))) (* ;  "FILEPKGCHANGES eliminates duplicates") (/replace CHANGED of TYPE with NIL)) (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) (* ;; "First check NIL=Nowhere. LST:1 contains variables whose values are on the file literally. These are `found' but not marked. LST::1 contains all other items.") (SETQ FOUND (NCONC (CAR LST) (CDR LST) FOUND)) do (SETQ PCHANGES (COND ((FMEMB (fetch DATEFILENAME of (CAR (fetch FILEDATES of FILE))) FLST) (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began. Thus, by this intersection we only worry about items that were previously changed; any items that were only changed during this operation are ignored.") (INTERSECTION CHANGED PREVITEMS)) (T CHANGED))) [COND ([AND PCHANGES [SETQ COMS (fetch COMSNAME of (SETQ FILEPROP (LISTP (fetch FILEPROP of FILE] (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE] (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms") [COND ((CDR LST) (* ; "CDR items must be distributed") [COND ((NULL (fetch TOBEDUMPED of FILEPROP)) (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL") [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL 'NOTLISTEDFILES] (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE (GETTOPVAL ' NOTCOMPILEDFILES ] (* ;  "Get the (possibly new) TYPE item list to smash") [COND [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED of FILEPROP] (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE] (* ;  "Now distribute items to the file property") (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP) ) do (/NCONC1 TYPEDPROP Y] (SETQ FOUND (NCONC (CAR LST) (CDR LST) FOUND] finally (/replace CHANGED of TYPE with (LDIFFERENCE CHANGED FOUND]) (INFILECOMS? [LAMBDA (NAME TYPE COMS ONFILETYPE) (* ; "Edited 12-Jul-88 17:42 by MASINTER") (* ;; "Returns T if NAME is 'CONTAINED' in COMS. If NAME is NIL, then value is a list of all of the functions contained in COMS. If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.) Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1. while elements are the subset of NAME which are on the file in other case") (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS? returns the dotted pair of (literals . elements) where literals are those which are `literally' on the file (e.g. (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned") (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ") (PROG (VAL LITERALS ORIGFLG) (SETQ TYPE (GETFILEPKGTYPE TYPE)) (SELECTQ ONFILETYPE (EDIT (SELECTQ TYPE (FILEVARS (RETURN)) NIL)) NIL) [COND ((LITATOM COMS) (SELECTQ TYPE ((VARS FILEVARS) (* ;  "the COMS of a file are also on it") (INFILECOMSVAL COMS)) NIL) (SETQ COMS (EVALV COMS] (INFILECOMS COMS) (SETQ VAL (DREVERSE VAL)) (RETURN (COND ((EQ ONFILETYPE 'UPDATE) (CONS LITERALS VAL)) (T VAL]) (INFILECOMTAIL [LAMBDA (COM FLG) (* ; "Edited 2-Aug-88 02:15 by masinter") [SETQ COM (COND ((EQ (CADR COM) '*) (COND [(LITATOM (CADDR COM)) (LISTP (EVALV (CADDR COM] (T [RESETVARS (DWIMLOADFNSFLG) (NLSETQ (SETQ COM (EVAL (CADDR COM] COM))) (T (CDR COM] (if (NOT FLG) then (for X in COM do [if (AND (LISTP X) (EQ (CAR X) COMMENTFLG)) then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X) (OR (NLISTP X) (NEQ (CAR X) COMMENTFLG] finally (RETURN COM)) else COM]) (INFILECOMS [LAMBDA (COMS) (* rmk%: "19-FEB-83 22:17") (for X in COMS do (INFILECOM X]) (INFILECOM [LAMBDA (COM) (* ; "Edited 2-Aug-88 02:27 by masinter") (COND [(NLISTP COM) (COND ((EQ TYPE 'VARS) (INFILECOMSVAL COM] ((EQ (CAR COM) COMMENTFLG) (* ;; "must be special case'd first so that (* * values) doesn't make it look like `values' is a variable") (* ;  "don't know why I should bother, but someone might want to know all of the comments on a file???") (COND ((EQ TYPE COMMENTFLG) (INFILECOMSVAL COM T))) NIL) (T (PROG ((COMNAME (CAR COM)) (TAIL (CDR COM)) CFN TEM) (COND [[COND ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME)) (SETQ TEM (APPLY* CFN COM (COND ((AND (NULL ONFILETYPE) (NOT (CL:SYMBOLP NAME))) (* ;  "call from WHEREIS of a name which is not a symbol") (LIST NAME)) (T NAME)) TYPE ONFILETYPE))) ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME)) (* ; "for compatability") (SETQ TEM (APPLY* CFN COM TYPE NAME] (COND [(NLISTP TEM) (COND ((EQ TEM T) (COND ((OR (EQ NAME T) (NULL ONFILETYPE)) (RETFROM 'INFILECOMS? T] (T (INFILECOMSVALS TEM] ((LISTP TAIL) (* ;; "this SELECTQ handles the `exceptional cases' for the built in types. There is an explicit RETURN in the SELECTQ clause if the default is handled") (SELECTQ COMNAME ((PROP IFPROP) (SETQ TAIL (CDR TAIL))) NIL) [COND ((EQ (CAR TAIL) '*) (COND ((LITATOM (CADR TAIL)) (SELECTQ TYPE ((VARS FILEVARS) (INFILECOMSVAL (CADR TAIL))) NIL)) ((AND (LISTP (CADR TAIL)) (EQ ONFILETYPE 'UPDATE) (EQ TYPE 'VARS) (EQ (CAADR TAIL) 'PROGN) (FMEMB (CAR (LAST (CADR TAIL))) NAME)) (SETQ VAL (CONS (CADR TAIL) VAL] (SELECTQ COMNAME ((COMS EXPORT) (INFILECOMS (INFILECOMTAIL COM T))) (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM) T))) (DECLARE%: (* ; "skip over DECLARE: tags") [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM)) (IFCDECLARE (INFILECOMTAIL COM) (EQ TYPE 'DECLARE%:]) (ORIGINAL (* ; "dont expand macros") (PROG ((ORIGFLG T)) (INFILECOMS (INFILECOMTAIL COM T)))) ((PROP IFPROP) (* ;  "this currently does not handle `pseudo-types' of PROPNAMES") (SELECTQ TYPE (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM) T) (CADR COM))) (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM)) (CADR COM))) NIL)) (PROPS (RETURN (IFCPROPS COM))) (MACROS (RETURN (SELECTQ TYPE (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T) MACROPROPS)) (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T))) NIL))) (ALISTS (* ;  "sigh. This should probably also `coerce' when asking for LISPXMACROS, etc.") (RETURN (SELECTQ TYPE (ALISTS (INFILEPAIRS (INFILECOMTAIL COM))) NIL))) (P [RETURN (SELECTQ TYPE ((EXPRESSIONS P) (INFILECOMSVALS (INFILECOMTAIL COM T) T)) (COND ((NULL ONFILETYPE) (* ; "for WHEREIS and FILECOMSLST") (SELECTQ TYPE (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR)) (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE)) NIL]) ((ADDVARS APPENDVARS) (SELECTQ TYPE (VARS [RETURN (AND (NULL ONFILETYPE) (for X in (INFILECOMTAIL COM T) do (INFILECOMSVAL (CAR X) T]) (ALISTS [RETURN (for X in (INFILECOMTAIL COM T) when (EQMEMB 'ALIST (GETPROP (CAR X) 'VARTYPE)) do (for Z in (CDR X) do (INFILECOMSVAL (LIST (CAR X) (CAR Z)) T]) (OR (EQ TYPE COMNAME) (RETURN)))) ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) [RETURN (COND ((EQ TYPE 'EXPRESSIONS) (for X in (INFILECOMTAIL COM T) when (AND (LISTP X) (NEQ (CAR X) COMMENTFLG)) do (INFILECOMSVAL (CONS 'SETQ X) T))) ((OR (EQ TYPE 'VARS) (EQ TYPE COMNAME))(* ;  "either want all VARS, or else want all FILEVARS and this is a FILEVARS command") (for X in (INFILECOMTAIL COM T) do (COND ((LISTP X) (AND (CAR X) (NEQ (CAR X) COMMENTFLG) (INFILECOMSVAL (CAR X) T))) (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS]) (DEFS [RETURN (for X in (INFILECOMTAIL COM T) when (EQ TYPE (CAR X)) do (INFILECOMSVALS (CDR X]) (FILES (RETURN)) NIL) (* ;; "Exceptional cases now handled. If TYPE matches (CAR COM) then scan the tail as usual. Else expand the com's MACRO, if it has one, unless there was a CONTENTS function") (COND ((EQ COMNAME TYPE) (INFILECOMSVALS (INFILECOMTAIL COM T))) [(AND (LISTP TYPE) (FMEMB COMNAME TYPE)) (LET ((TYPE COMNAME)) (INFILECOMSVALS (INFILECOMTAIL COM T] ((AND (OR (NULL CFN) (AND (EQ CFN T) (NULL ONFILETYPE))) (NULL ORIGFLG) (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME))) (INFILECOMS (SUBPAIR (CAR TEM) (INFILECOMTAIL COM T) (CDR TEM]) (INFILECOMSVALS [LAMBDA (X FLG) (* ; "Edited 2-Aug-88 02:21 by masinter") (for Y in X when (NOT (AND (LISTP Y) (EQ (CAR Y) COMMENTFLG))) do (INFILECOMSVAL Y FLG]) (INFILECOMSVAL [LAMBDA (X FLG) (* ; "Edited 12-Jul-88 17:56 by MASINTER") (COND [(EQ ONFILETYPE 'UPDATE) (AND (OR (NULL NAME) (MEMBER X NAME)) (COND (FLG (SETQ LITERALS (CONS X LITERALS))) (T (SETQ VAL (CONS X VAL] ((AND (EQ ONFILETYPE 'EDIT) FLG) (* ;  "literals should not be edited as they are on the fileCOMS") NIL) ((EQ ONFILETYPE 'TYPESOF) (AND (COND ((LITATOM NAME) (EQ NAME X)) (T (EQUAL NAME X))) (CL:PUSHNEW TYPE VAL))) ([OR (EQ NAME T) (COND ((LITATOM NAME) (EQ NAME X)) (T (EQUAL NAME X] (RETFROM (FUNCTION INFILECOMS?) T)) ((NULL NAME) (SETQ VAL (CONS X VAL]) (INFILECOMSPROP [LAMBDA (AT PROP) (* lmm "25-SEP-81 17:15") (COND [(EQ ONFILETYPE 'UPDATE) (AND [OR (NULL NAME) (find X in NAME suchthat (AND (EQ (CAR X) AT) (EQ (CADR X) PROP] (SETQ VAL (CONS (LIST AT PROP) VAL] ((OR (EQ NAME T) (AND (EQ (CAR NAME) AT) (EQ (CADR NAME) PROP))) (RETFROM (FUNCTION INFILECOMS?) T)) ((NULL NAME) (SETQ VAL (CONS (LIST AT PROP) VAL]) (IFCPROPS [LAMBDA (COM) (* bvm%: " 2-Dec-83 14:24") (* ;;; "Examine a PROPS com for objects of specified TYPE") (SELECTQ TYPE (PROPS (* ;  "the PROPS command can actually take (PROPNAME at1 at2 ...)") (INFILEPAIRS (INFILECOMTAIL COM))) (PROP (* ;  "return the atoms which have any properties at all") (for PAIR in (INFILECOMTAIL COM) do (for ATNAME inside (CAR PAIR) do (INFILECOMSVAL ATNAME )))) (MACROS (* ; "only MACRO properties") (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR) (CDR PAIR)))) NIL]) (IFCEXPRTYPE [LAMBDA (COM FN) (* ; "Edited 6-Apr-87 20:20 by Pavel") (* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN") (for SUBCOM in (INFILECOMTAIL COM) when (AND (EQ (CAR SUBCOM) FN) (EQ (CAR (LISTP (CADR SUBCOM))) 'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM)) T]) (IFCPROPSCAN [LAMBDA (ATOMS PROPNAMES) (* ; "Edited 2-Aug-88 02:20 by masinter") (* ;;; "Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES") (for AT in ATOMS WHEN (LITATOM AT) unless [COND [(EQ ONFILETYPE 'UPDATE) (COND (NAME (NOT (ASSOC AT NAME] ((LISTP NAME) (NEQ AT (CAR NAME] do (COND ((EQ PROPNAMES 'ALL) (for PROP in (GETPROPLIST AT) by (CDDR PROP) when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP))) (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP]) (IFCDECLARE [LAMBDA (TAIL WANTDECLARE) (* ; "Edited 8-Jun-90 18:11 by teruuchi") (PROG ((TAIL TAIL)) LP (COND ((LISTP TAIL) [SELECTQ (CAR TAIL) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL) (CADR TAIL] (SETQ TAIL (CDR TAIL))) (DONTEVAL@LOAD [COND ((OR (\STKSCAN 'DOFILESLOAD) (\STKSCAN 'LOAD)) (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"") (RETURN)) (WANTDECLARE (INFILECOMSVAL (CAR TAIL]) (COMPILERVARS (RETURN)) (COND [(FMEMB (CAR TAIL) DECLARETAGSLST) (COND (WANTDECLARE (INFILECOMSVAL (CAR TAIL] (T (INFILECOM (CAR TAIL] (SETQ TAIL (CDR TAIL)) (GO LP]) (INFILEPAIRS [LAMBDA (LST) (* lmm " 4-DEC-78 09:51") (for LL in LST do (for X inside (CAR LL) do (for Y inside (CDR LL) do (INFILECOMSVAL (LIST X Y]) (INFILECOMSMACRO [LAMBDA (ATS PROPS) (* lmm "28-SEP-78 18:35") (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it. --- Normally (e.g. for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom. However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties") (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE) (EVERY (PROPNAMES AT) (FUNCTION (LAMBDA (X) (OR (NOT (FMEMB X MACROPROPS)) (EQMEMB X PROPS] [SOME MACROPROPS (FUNCTION (LAMBDA (PROP) (EQMEMB PROP PROPS] (INFILECOMSVAL AT]) ) (* ;; "adding to a file") (DEFINEQ (FILES? [LAMBDA NIL (* bvm%: "27-Oct-86 18:14") (* ;;; "Display each file needing dumping, etc. For files needing dumping, display details of why.") (UPDATEFILES) (LET (FILES CHANGES PRINTED) (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED of (LISTP (fetch FILEPROP of FILE] do (if (NOT PRINTED) then (LISPXPRIN1 "To be dumped: " T) (SETQ PRINTED T)) (LISPXPRIN2 FILE T) (LISPXPRIN1 " ...changes to " T) [for CH in CHANGES bind TB do (COND ((LISTP CH) [COND (TB (LISPXTAB TB NIL T)) (T (SETQ TB (POSITION T] (LISPXPRIN2 (CAR CH) T) (FILES?PRINTLST (CDR CH))) (T (* ; "old style") (LISPXPRIN2 CH T) (LISPXSPACES 1 T] (LISPXTERPRI T)) (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED " plus ")) do (SETQ FLG T) finally (if FLG then (OR PRINTED (LISPXPRIN1 "...to be dumped. " T)) (ADDTOFILES?))) (if (SETQ FILES NOTCOMPILEDFILES) then (FILES?PRINTLST FILES "To be compiled: ") (LISPXTERPRI T)) (if (SETQ FILES NOTLISTEDFILES) then (FILES?PRINTLST FILES "To be listed: ") (LISPXTERPRI T)) (CL:VALUES]) (FILES?1 [LAMBDA (TYPE FIRST) (* bvm%: "27-Oct-86 18:17") (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.") (LET (STR LST) (COND ([AND (LITATOM TYPE) (SETQ STR (fetch DESCRIPTION of TYPE)) (LISTP (SETQ LST (fetch CHANGED of TYPE] (AND FIRST (LISPXPRIN1 FIRST T)) (LISPXPRIN1 '"the " T) (LISPXPRIN1 STR T) (FILES?PRINTLST LST) (LISPXTERPRI T) T]) (FILES?PRINTLST [LAMBDA (LST STR) (* bvm%: "27-Oct-86 18:15") (* ;; "Print elements of LST separated by commas and indenting new lines a bunch. If MAPRINT had a left margin arg, this would be simpler.") (MAPRINT LST T (OR STR ": ") NIL ", " [FUNCTION (LAMBDA (STR) (COND ((> (+ (POSITION T) (NCHARS STR T T) 3) (LINELENGTH NIL T)) (LISPXTERPRI T) (LISPXPRIN1 " " T))) (LISPXPRIN2 STR T T] T]) (ADDTOFILES? [LAMBDA (NOASKSTR) (* ; "Edited 10-Aug-2020 21:18 by rmk:") (* ; "Edited 21-Aug-91 10:13 by jds") (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says") (* ;; "RMK: Eliminated literal CR's in the key list.") (ERSETQ (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS] (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g. changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES") [COND (NOASKSTR (PRIN1 NOASKSTR T)) (T (DOBE) (SETQ BUFS (READP T)) (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go") `([Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL] [N ,(CONCAT "o" (CHARACTER (CHARCODE EOL] (%] ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL))) EXPLAINSTRING "] - nowhere, all items will be marked as dummy " NOECHOFLG T)) T) (N (RETURN)) (%] (* ; "Nowhere") (for TYPE in FILEPKGTYPES do (for NAME in (fetch (FILEPKGTYPE CHANGED) of TYPE) do (ADDTOFILE NAME TYPE NIL))) (RETURN)) NIL) (* ;  "if there was type-ahead BEFORE the askuser, then don't allow it now") (COND (BUFS (SETQ BUFS (COND ((READP T) (LINBUF) (SYSBUF) (SETQ BUFS (CLBUFS NIL T READBUF] [for TYPE STR LST in FILEPKGTYPES when [AND (SETQ STR (fetch DESCRIPTION of TYPE)) (LISTP (SETQ LST (COND ((EQ TYPE 'VARS) VARSCHANGES) (T (fetch (FILEPKGTYPE CHANGED) of TYPE] do (printout T "(" STR ")" T) (for NAME TEM FILE in LST when NAME do (PROG NIL LP (PRIN2 NAME T) (SPACES 2 T) (* ;; "if user typed ahead before entering addtofiles?? then dont allow typeahead here, because it will justgobble his earlier typeahead.") (* ;; "SELCHARQ to avoid literal CR") (SELCHARQ (CHCON1 (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T))) (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T) (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer") (DOBE))) (GO LP)) (%] (* ; "Nowhere") (SETQ FILE)) (SPACE (* ; "No action") (RETURN)) ((LF =) (PRINT (OR (SETQ FILE LASTFILE) 'Nowhere) T)) (SETQ FILE TEM)) (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR) (SETQ PLACE (WHATIS FILE NIL TYPE)) [COND ((LITATOM PLACE) (* ; "file name") (SETQ FILE PLACE) (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE)) NAME TYPE NEAR LISTNAME) (ADDNEWCOM COMSNAME NAME TYPE NIL FILE)) (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE)) (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.") ) ((EQ (CAR PLACE) 'Near%:) (SETQ NEAR (CADR PLACE)) (COND ([SOME FILELST (FUNCTION (LAMBDA (FL) (ADDTOCOMS (FILECOMS (SETQ FILE FL)) NAME TYPE NEAR LISTNAME] (PRINT (LIST 'on FILE) T T)) (T (PRINT (LIST (CADR PLACE) 'not 'found) T T) (ERROR!))) (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))) ([OR [UNDONLSETQ (PROGN (SAVESET (SETQ LISTNAME (CAR PLACE)) (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME)) T) T 'NOPRINT) (OR (SETQ FILE (CAR (WHEREIS NAME TYPE FILELST))) (ERROR!] (SOME FILELST (FUNCTION (LAMBDA (X) (ADDTOCOMS (FILECOMS (SETQ FILE X)) NAME TYPE NEAR LISTNAME] (PRIN1 " value is filed on " T) (PRINT FILE T T) (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE)) (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed") ) (T (PRIN1 " put list " T) (PRIN2 (CAR PLACE) T T) (SETQ FILE (WHATIS (ASKUSER NIL NIL " on file: " '(("" "" EXPLAINSTRING "a file name" KEYLST ())) T) 'FILE)) (SAVESET (CAR PLACE) (MERGEINSERT NAME (LISTP (GETTOPVAL (CAR PLACE))) T) T 'NOPRINT) (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.") (ADDNEWCOM (FILECOMS FILE) NAME TYPE (CAR PLACE) FILE) (for F in (fetch WHENFILED of TYPE) do (for I in (GETTOPVAL (CAR PLACE)) do (APPLY* F I TYPE FILE] (AND FILE (ADDFILE FILE)) (SETQ LASTFILE PLACE))) (GO LP] (AND BUFS (BKBUFS BUFS)) (UPDATEFILES]) (ADDTOFILE [LAMBDA (NAME TYPE FILE NEAR LISTNAME) (* lmm "21-Nov-84 11:43") (* ; "adds NAME to the file FILE") (PROG (TEM COMSNAME) [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T) (COND ((FMEMB TYPE FILELST) (GETFILEPKGTYPE (swap TYPE FILE))) (T (GETFILEPKGTYPE TYPE] (SETQ FILE (WHATIS FILE 'FILE)) (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE)) NAME TYPE NEAR LISTNAME) (ADDNEWCOM COMSNAME NAME TYPE NIL FILE)) (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE)) (AND FILE (NOT (FMEMB FILE FILELST)) (ADDFILE FILE)) (RETURN FILE]) (WHATIS [LAMBDA (USERINPUT ONLY) (* lmm "28-Nov-84 16:49") (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble; if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable") (PROG (TEM UCASE) (RETURN (COND ((NULL USERINPUT) (* ; "nowhere") NIL) [(LISTP USERINPUT) (COND (ONLY (ERROR!)) (T (SELECTQ (CAR USERINPUT) ((@ Near%:) (CONS 'Near%: (CDR USERINPUT))) (WHATIS (CAR USERINPUT) 'LIST] ([AND (NEQ ONLY 'LIST) (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT))) FILELST) (LISTP (GETTOPVAL (FILECOMS UCASE))) (SETQ TEM (FIXSPELL UCASE NIL FILELST T] TEM) ((AND (NEQ ONLY 'FILE) (LISTP (GETTOPVAL USERINPUT))) (LIST USERINPUT)) ((AND (NEQ ONLY 'LIST) (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE) NIL T) 'Y)) UCASE) ((AND (NEQ ONLY 'FILE) (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT) NIL T) 'Y)) (LIST USERINPUT)) (T (* ; "none of above") (ERROR!]) (ADDTOCOMS [LAMBDA (COMS NAME TYPE NEAR LISTNAME) (* rmk%: "10-JUN-82 22:53") (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms); return NIL if unsuccessful. If LISTNAME is given, then only insert by adding to LISTNAME. If NEAR is given, only insert near it") (COND ((NULL COMS) NIL) [(LITATOM COMS) (* ;  "given a name of a command; rebind COMSNAME to current variable and try to add to its value") (OR [PROG ((COMSNAME COMS)) (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME)) NAME TYPE NEAR (AND (NEQ COMS LISTNAME) LISTNAME] (AND (EQ COMS LISTNAME) (ADDNEWCOM COMS NAME TYPE] (T (SETQ TYPE (GETFILEPKGTYPE TYPE)) (for TAIL on COMS do (COND [(LISTP (CAR TAIL)) (COND ((ADDTOCOM (CAR TAIL) NAME TYPE NEAR LISTNAME) (RETURN T] (T (SELECTQ (CAR TAIL) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (SETQ TAIL (CDR TAIL))) NIL]) (ADDTOCOM [LAMBDA (COM NAME TYPE NEAR LISTNAME) (* ; "Edited 2-May-87 19:04 by Pavel") (* ;  "tries to insert NAME into the prettycom COM; returns NIL if unsuccessful") (PROG (TEM) (COND ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM] (RETURN))) [COND ((SETQ TEM (fetch ADD of (CAR COM))) (RETURN (COND ((OR (NULL LISTNAME) (INFILECOMS? LISTNAME 'FILEVARS (LIST COM))) (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR)) (MARKASCHANGED COMSNAME 'VARS)) TEM] (RETURN (SELECTQ (CAR COM) (FNS (AND (EQ TYPE 'FNS) (ADDTOCOM1 COM NAME NEAR LISTNAME))) ((VARS INITVARS) (COND ((OR (EQ (CAR COM) 'VARS) NEAR LISTNAME) (* ;  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.") (SELECTQ TYPE (EXPRESSIONS (COND ((EQ (CAR NAME) 'SETQ) (ADDTOCOM1 COM (CDR NAME) NEAR LISTNAME)))) (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME)) NIL)))) (COMS (ADDTOCOMS (COND [(EQ (CADR COM) '*) (COND ((LITATOM (CADDR COM)) (CADDR COM)) (T (RETURN] (T (CDR COM))) NAME TYPE NEAR LISTNAME)) (DECLARE%: (AND (OR LISTNAME NEAR) (ADDTOCOMS (COND [(EQ (CADR COM) '*) (COND ((LITATOM (CADDR COM)) (CADDR COM)) (T (RETURN] (T (CDR COM))) NAME TYPE NEAR LISTNAME))) (CL:EVAL-WHEN (AND (OR LISTNAME NEAR) (ADDTOCOMS (COND [(EQ (CL:THIRD COM) '*) (COND ((LITATOM (CL:FOURTH COM)) (CL:FOURTH COM)) (T (RETURN] (T (CDDR COM))) NAME TYPE NEAR LISTNAME))) ((PROP IFPROP) (SELECTQ TYPE (PROPS (COND ((EQ (CADR COM) (CADR NAME)) (ADDTOCOM1 (CDR COM) (CAR NAME) NEAR LISTNAME)) ((AND (EQ (CAR NAME) (CADDR COM)) (NULL (CDDDR COM))) [/RPLACA (CDR COM) (UNION (MKLIST (CDR NAME)) (MKLIST (CADR COM] (MARKASCHANGED COMSNAME 'VARS) T))) (MACROS (COND ([AND (for PROP inside (CADR COM) always (EQMEMB PROP MACROPROPS)) (for PROP in MACROPROPS always (OR (EQMEMB PROP (CADR COM)) (NOT (GETPROP NAME PROP] (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed") (ADDTOCOM1 (CDR COM) NAME NEAR LISTNAME)))) NIL)) ((PROPS ALISTS) (AND (EQ TYPE (CAR COM)) (ADDTOCOM1 COM (/NCONC1 (OR [ASSOC (CAR NAME) (COND [(EQ (CADR COM) '*) (COND [(LITATOM (CADDR COM)) (AND (OR (NULL LISTNAME) (EQ (CADDR COM) LISTNAME)) (GETTOPVAL (CADDR COM] (T (RETURN] (T (CDR COM] (LIST (CAR NAME))) (CADR NAME)) NEAR LISTNAME))) (P (COND ((AND (EQ TYPE 'EXPRESSIONS) (NEQ (CAR NAME) 'SETQ)) (ADDTOCOM1 COM NAME NEAR LISTNAME)))) (AND (EQ (CAR COM) TYPE) (ADDTOCOM1 COM NAME NEAR LISTNAME]) (ADDTOCOM1 [LAMBDA (COM NAME NEAR LISTNAME) (* rmk%: " 3-JAN-82 22:53") (COND [(EQ (CADR COM) '*) (* ; "add to list name") (AND [COND (LISTNAME (EQ (CADDR COM) LISTNAME)) (T (LITATOM (CADDR COM] (SAVESET (CADDR COM) [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM] (COND ((AND NEAR (SETQ NEAR (MEMBER NEAR COM))) (/RPLACD NEAR (CONS NAME (CDR NEAR))) COM) (T (MERGEINSERT NAME COM T] T 'NOPRINT] ((NULL LISTNAME) (* ; "add to standard com") [AND (NOT (MEMBER NAME (CDR COM))) (COND [(SETQ NEAR (MEMBER NEAR COM)) (/RPLACD NEAR (CONS NAME (CDR NEAR] (T (/RPLACD COM (MERGEINSERT NAME (CDR COM] (MARKASCHANGED COMSNAME 'VARS) T]) (ADDNEWCOM [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE) (* rmk%: " 3-JAN-82 22:53") (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE. --- if LISTNAME is given, then use it as the listname") (PROG (NEWCOM OLDCOM TAIL) (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE)) [COND ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME))) (RETURN (SAVESET COMSNAME (LIST NEWCOM) T 'NOPRINT] LP [COND ((OR (NLISTP (SETQ OLDCOM (CAR TAIL))) (SELECTQ (CAR OLDCOM) ((LOCALVARS SPECVARS BLOCKS) T) (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM))) NIL)) (/ATTACH NEWCOM TAIL)) ((LISTP (CDR TAIL)) (SETQ TAIL (CDR TAIL)) (GO LP)) (T (/RPLACD TAIL (LIST NEWCOM] (MARKASCHANGED COMSNAME 'VARS]) (MAKENEWCOM [LAMBDA (NAME TYPE LISTNAME FILE) (* ; "Edited 8-Apr-87 14:55 by Pavel") (SETQ TYPE (GETFILEPKGTYPE TYPE)) (PROG (TEM) (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname") (AND (LISTP NAME) (SETQ NAME (COPY NAME))) (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE)) (APPLY* TEM NAME TYPE LISTNAME FILE)) (SELECTQ TYPE (PROPS [AND (NULL LISTNAME) (CONS 'PROP (CONS (COND ((AND (LISTP (CDR NAME)) (NULL (CDDR NAME))) (CADR NAME)) (T (CDR NAME))) (OR (LISTP (CAR NAME)) (LIST (CAR NAME]) (EXPRESSIONS [COND ((EQ (CAR NAME) 'SETQ) (MAKENEWCOM (CDR NAME) 'VARS LISTNAME FILE)) (T (CONS 'P (COND (LISTNAME (LIST '* LISTNAME)) (T (LIST NAME]) NIL) (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE]) (DEFAULTMAKENEWCOM [LAMBDA (NAME TYPE LISTNAME FILE) (* lmm "20-OCT-82 22:48") (COND ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST) (fetch MACRO of TYPE) (fetch GETDEF of TYPE))) (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION of TYPE) TYPE) T)) ((NULL DEFAULTCOMHASFILEFLG) (* ; "disable FOOFNS FOOVARS junk") (LIST TYPE NAME)) ((EQ FILE T) (* ;  "FILE=T only when called from SHOWDEF") (LIST TYPE NAME)) ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE)) (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME)) T) T 'NOPRINT] (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items") (LIST TYPE '* LISTNAME)) (T (LIST TYPE NAME]) ) (RPAQ? DEFAULTCOMHASFILEFLG ) (ADDTOVAR MARKASCHANGEDFNS ) (DEFINEQ (MERGEINSERT [LAMBDA (NEW LST ONEFLG) (* lmm "30-Jun-86 18:11") (* ;; "searches LST to find the most reasonable place to insert NEW. Does nothing if ONEFLG is T and NEW is already a member of LST") (COND ((AND ONEFLG (MEMBER NEW LST)) LST) ((LISTP NEW) (/NCONC1 LST NEW)) (T (PROG ((N 0) LST1 PLACE TEM) (SETQ LST1 LST) LP (* ;; "finds the function with the longest leading common substring. The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.") (COND ((NULL LST1) (GO OUT)) ((OR (LISTP (CAR LST1)) (SETQ TEM (STRPOS (CAR LST1) NEW 1 NIL T T))) (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE") (SETQ PLACE LST1) (GO OUT)) ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1) NEW)) N) (SETQ N TEM) (SETQ PLACE LST1))) (SETQ LST1 (CDR LST1)) (GO LP) OUT (SETQ TEM (CAR PLACE)) (OR [SOME (OR PLACE LST) (FUNCTION (LAMBDA (X LST) (COND ([OR (ALPHORDER NEW X) (AND PLACE (NOT (ALPHORDER TEM X] (* ;; "for example, if the FNS list is something like (... FOO FOO1 ...) where the ... may or may not be in order, e.g. (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.") (/ATTACH NEW LST)) (T (SETQ TEM X) NIL] (SETQ LST (/NCONC1 LST NEW))) (RETURN LST]) (MERGEINSERT1 [LAMBDA (X Y) (* rmk%: "24-MAY-82 00:05") (* ;; "value is the number of leading characters of X and Y that agree.") (PROG ((N 1) C1 C2) LP [COND ((OR (NULL (SETQ C1 (NTHCHARCODE X N))) (NULL (SETQ C2 (NTHCHARCODE Y N))) (NEQ C1 C2)) (RETURN (SUB1 N] (SETQ N (ADD1 N)) (GO LP]) ) (* ;; "RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file" ) (DEFINEQ (ADDTOFILEKEYLST [LAMBDA NIL (* ; "Edited 12-Feb-2021 17:15 by larry") `(("[" "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" NOECHOFLG T) (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T) (,(CHARACTER (CHARCODE LF)) "" EXPLAINSTRING "{line-feed} - same as previous response" NOECHOFLG T) (" " ,(CONCATCODES (LIST (CHARCODE SPACE) (CHARCODE EOL))) EXPLAINSTRING "{space} - no action" NOECHOFLG T) ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL))) EXPLAINSTRING ,(CONCAT "] - nowhere, item is marked as a dummy" (CHARACTER (CHARCODE EOL))) NOECHOFLG T) ["(" "List: (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE)) ,(CHARACTER (CHARCODE EOL] RETURN (CDR ANSWER] (@ "Near: " EXPLAINSTRING "@ other-item -- put the item near the other item" NOECHOFLG T KEYLST (( "" CONFIRMFLG [,(CHARACTER (CHARCODE EOL] RETURN ANSWER))) [,(CHARACTER (CHARCODE CR)) "" RETURN ,(CHARACTER (CHARCODE SPACE] ("" "File name: " EXPLAINSTRING "a file name" KEYLST (]) ) (RPAQ? ADDTOFILEKEYLST (ADDTOFILEKEYLST)) (RPAQ? LASTFILE ) (* ;; "deleting an item from a file") (DEFINEQ (DELFROMFILES [LAMBDA (NAME TYPE FILES) (* rmk%: " 6-MAR-82 13:16") (* ;; "Eliminates NAME as an item of type TYPE in COMS.") (PROG (COMS) (SETQ TYPE (GETFILEPKGTYPE TYPE)) (RETURN (for FILE inside (OR FILES FILELST) when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE)) NAME TYPE) (COND ((INFILECOMS? NAME TYPE COMS) (printout T "(could not delete " NAME " from " FILE ")" T)))) collect (for FN in (fetch WHENUNFILED of TYPE) do (APPLY* FN NAME TYPE FILE)) FILE]) (DELFROMCOMS [LAMBDA (COMS NAME TYPE) (* bvm%: " 1-Oct-86 22:02") (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list). Returns T if it does anything") (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.") (COND [(LITATOM COMS) (LET ((COMSNAME COMS)) (DECLARE (SPECVARS COMS)) (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME))) (DELFROMCOMS COMS NAME TYPE] (T (PROG (DONE) (SETQ TYPE (GETFILEPKGTYPE TYPE)) LP (COND ((NLISTP COMS) (RETURN DONE))) [COND ((LISTP (CAR COMS)) (SELECTQ (DELFROMCOM (CAR COMS) NAME TYPE) (ALL (/RPLNODE2 COMS (CDR COMS)) (SETQQ DONE ALL) (GO LP)) (NIL) (SETQ DONE T))) (T (SELECTQ (CAR COMS) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (SETQ COMS (CDR COMS))) (COND ((AND (EQ TYPE 'VARS) (EQ NAME (CAR COMS))) (/RPLNODE2 COMS (CDR COMS)) (SETQ DONE T) (GO LP] (SETQ COMS (CDR COMS)) (GO LP]) (DELFROMCOM [LAMBDA (COM NAME TYPE) (* ; "Edited 2-May-87 19:02 by Pavel") (* ; "Tries to delete NAME from COM") (PROG (TEM VAR NEW) (COND ((SETQ TEM (fetch DELETE of (CAR COM))) (AND (SETQ TEM (APPLY* TEM COM NAME TYPE)) (MARKASCHANGED COMSNAME 'VARS)) (RETURN TEM))) (RETURN (SELECTQ (CAR COM) ((DECLARE%: COMS) (DELFROMCOMS (COND [(EQ (CADR COM) '*) (COND ((LITATOM (CADDR COM)) (CADDR COM)) (T (RETURN] (T (CDR COM))) NAME TYPE)) ((CL:EVAL-WHEN) (DELFROMCOMS (COND [(EQ (CL:THIRD COM) '*) (COND ((LITATOM (CL:FOURTH COM)) (CL:FOURTH COM)) (T (RETURN] (T (CDDR COM))) NAME TYPE)) ((ALISTS PROPS) (AND (EQ TYPE (CAR COM)) (COND ((EQ (CADR COM) '*) (COND ([AND (LITATOM (SETQ VAR (CADDR COM))) (SETQ TEM (ASSOC (CAR NAME) (GETTOPVAL VAR))) (NEQ (CDR TEM) (SETQ TEM (REMOVEITEM (CADR NAME) (CDR TEM] (SAVESET VAR TEM T 'NOPRINT) T))) ([AND [CDR (SETQ TEM (ASSOC (CAR NAME) (CDR COM] (NEQ (CDR TEM) (SETQ NEW (REMOVEITEM (CADR NAME) (CDR TEM] (/RPLACD TEM NEW) (MARKASCHANGED COMSNAME 'VARS) T)))) (BLOCKS (* ;; "Remove function name from blocks declarations. This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.") [AND (EQ TYPE 'FNS) (for BLOCK in (INFILECOMTAIL COM T) do (AND (MEMB NAME BLOCK) (/DREMOVE NAME BLOCK)) (for X in BLOCK when (AND (LISTP X) (MEMB NAME (CDR X))) do (/RPLACD X (REMOVE NAME (CDR X]) ((PROP IFPROP) [SELECTQ TYPE (PROPS (RETURN (COND ((EQ (CADR COM) (CADR NAME)) (DELFROMCOM1 (CDR COM) (CAR NAME))) ((AND (EQMEMB (CADR NAME) (CADR COM)) [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM] (EQ (CAR TEM) (CAR NAME))) [/RPLACA (CDR COM) (REMOVE (CADR NAME) (MKLIST (CADR COM] (MARKASCHANGED COMSNAME 'VARS) T)))) (COND ([for PROP inside (CADR COM) always (EQ TYPE (GETPROP PROP 'PROPTYPE] (DELFROMCOM1 (CDR COM) NAME]) ((RECORDS INITRECORDS SYSRECORDS) (AND (EQ TYPE 'RECORDS) (DELFROMCOM1 COM NAME))) (P (AND (EQ TYPE 'EXPRESSIONS) (DELFROMCOM1 COM NAME))) ((VARS INITVARS) (AND (EQ TYPE 'VARS) (DELFROMCOM1 COM NAME T))) (AND (EQ TYPE (CAR COM)) (DELFROMCOM1 COM NAME]) (DELFROMCOM1 [LAMBDA (COM NAME FLG) (* rmk%: "10-JUN-82 22:44") (* ;;  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed") (LET (TEM VAL) (COND ((EQ (CADR COM) '*) (COND ([AND (LITATOM (SETQ TEM (CADDR COM))) (NEQ (SETQ VAL (GETTOPVAL TEM)) (SETQ VAL (REMOVEITEM NAME VAL FLG] (SAVESET TEM VAL T 'NOPRINT) T))) ((NEQ (CDR COM) (SETQ TEM (REMOVEITEM NAME (CDR COM) FLG))) (/RPLACD COM TEM) (MARKASCHANGED COMSNAME 'VARS) T]) (REMOVEITEM [LAMBDA (X LST FLG) (* ; "Edited 25-May-88 17:52 by drc:") (* lmm "10-FEB-78 17:29") (* ;;  "returns a subset of LST with X deleted; if FLG is set, also remove elements whose CAR is X") (COND [[OR (MEMBER X LST) (AND FLG (SOME LST (FUNCTION (LAMBDA (Y) (EQUAL (CAR (LISTP Y)) X] (SUBSET LST (FUNCTION (LAMBDA (Y) (AND (NOT (EQUAL Y X)) (OR (NOT FLG) (NLISTP Y) (NOT (EQUAL (CAR Y) X] (T LST]) (MOVETOFILE [LAMBDA (TOFILE NAME TYPE FROMFILE) (* rmk%: "18-OCT-79 19:51") (* ; "To move items between files") (SETQ TYPE (GETFILEPKGTYPE TYPE)) [COND ((OR (EQ TYPE 'FNS) FROMFILE) (* ;  "FNS definition can reside on file if LOADFNS was done. This guarantees that it is loaded.") (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM] (AND (EQ TYPE 'FNS) (MARKASCHANGED NAME TYPE)) (* ;  "FNS won't get dumped unless they are `changed'") (DELFROMFILES NAME TYPE FROMFILE) (ADDTOFILE NAME TYPE TOFILE]) ) (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T) (MOVD? 'MOVETOFILE 'MOVEITEM NIL T) (ADDTOVAR SYSPROPS PROPTYPE VARTYPE) (* ; "functions for doing things and marking them changed and auxiliary functions") (DEFINEQ (SAVEPUT [LAMBDA (ATM PROP VAL) (* lmm " 7-May-84 16:56") (* ;; "analogous to SAVESET but also marks changed property lists; LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT") [COND ((NOT (LITATOM ATM)) (ERRORX (LIST 14 ATM] (PROG ((X (GETPROPLIST ATM)) X0 TEM OLDFLG) LOOP (COND ((NLISTP X) (COND ((AND (NULL X) X0) (* ;  "typical case. property list ran out on an even parity position. e.g. (A B C D)") (SETQ TEM (LIST PROP VAL)) (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM) LISPXHIST)) (FRPLACD (CDR X0) TEM) (GO RET))) (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning") ) ((NLISTP (CDR X)) (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g. (A B C) or (A B C . D) fall through and add at beginning.") ) [(EQ (CAR X) PROP) (SETQ OLDFLG (NEQ (EQUALN (CADR X) VAL 400) T)) (* ; "i.e. it probably changed") (/RPLACA (CDR X) VAL) (COND ((NOT OLDFLG) (GO RET1)) (T (OR (EQ DFNFLG T) (LISPXPRINT (LIST 'new PROP 'property 'for ATM) T T)) (GO RET] (T (SETQ X (CDDR (SETQ X0 X))) (GO LOOP))) [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM] (SETPROPLIST ATM TEM) (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM) LISPXHIST)) RET (MARKASCHANGED (LIST ATM PROP) 'PROPS (NOT OLDFLG)) RET1 (AND ADDSPELLFLG (ADDSPELL ATM 0)) (RETURN VAL]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT) (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT)) ) (DEFINEQ (UNMARKASCHANGED [LAMBDA (NAME TYPE) (* JonL "24-Jul-84 19:59") (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties. Value is name if anything is done") (PROG (ANYFLG) (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE] while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL) (SETQ ANYFLG T)) [for F TAIL PROP TYPEDPROP in FILELST when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED of (SETQ PROP (fetch FILEPROP of F] do (SETQ ANYFLG T) (COND ((SETQ TAIL (REMOVE (CAR TAIL) (CDR TYPEDPROP))) (/RPLACD TYPEDPROP TAIL)) (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP (fetch TOBEDUMPED of PROP] (RETURN (AND ANYFLG NAME]) (PREEDITFN [LAMBDA (ATM TYPE EDITCHANGES) (* rmk%: "18-FEB-82 21:49") (* ;  "EDITL is advised to call this before editing something") (AND FILEPKGFLG (SELECTQ TYPE (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS) (CONS)) CLISPARRAY)) (for X in (GETPROPLIST ATM) do (OR (NLISTP X) (GETHASH X CLISPARRAY) (PUTHASH X (CONS (CAR X) (CDR X)) CLISPARRAY] (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made") [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS) EDITCHANGES (APPEND (GETPROPLIST ATM]) (VARS [COND ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE)) [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS) (CONS)) CLISPARRAY)) (for X in (EVALV ATM) do (OR (NLISTP X) (GETHASH X CLISPARRAY) (PUTHASH X (CONS (CAR X) (CDR X)) CLISPARRAY] (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS) EDITCHANGES (for X in (EVALV ATM) collect (CAR X]) NIL]) (POSTEDITPROPS [LAMBDA (EDITCHANGES OLDPROPS) (* rmk%: "18-FEB-82 21:50") (* ; "was RESETSAVE'd from PREEDITFN") (PROG (OV FOUNDCHANGE) (OR FILEPKGFLG (RETURN)) (COND ((CADR EDITCHANGES) (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP) when (for OLDPROP on OLDPROPS by (CDDR OLDPROP) do (COND ((EQ (CAR OLDPROP) (CAR NEWPROP)) (* ; "Found the property") [AND (EQ (CADR OLDPROP) (CADR NEWPROP)) (COND ((NLISTP (CADR OLDPROP)) (* ; "value is same") (RETURN)) ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP) CLISPARRAY)) (EQ (CAADR NEWPROP) (CAR OV)) (EQ (CDADR NEWPROP) (CDR OV))) (PUTHASH (CADR NEWPROP) NIL CLISPARRAY) (* ;  "value has been edited (CLISPARRAY translation went away)") (RETURN] (RETURN T))) finally (* ; "didn't find the property") (RETURN T)) do (MARKASCHANGED (LIST (CAR EDITCHANGES) (CAR NEWPROP)) 'PROPS NIL) (SETQ FOUNDCHANGE T)) (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES) NIL]) (POSTEDITALISTS [LAMBDA (EDITCHANGES OLDTOKENS) (* rmk%: " 4-JAN-82 10:14") (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES] (* ;  "called after an ALIST has been edited") (OR FILEPKGFLG (RETURN)) (COND ((CADR EDITCHANGES) (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES)) do (MARKASCHANGED (LIST (CAR EDITCHANGES) X) 'ALISTS NIL) (SETQ FOUNDCHANGE T)) [for NEWENTRY in NEWENTRIES do (COND ([AND (LISTP NEWENTRY) (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY)) (EQ (CAR NEWENTRY) (CAR OV)) (EQ (CDR NEWENTRY) (CDR OV] (PUTHASH NEWENTRY NIL CLISPARRAY) (MARKASCHANGED (LIST (CAR EDITCHANGES) (CAR NEWENTRY)) 'ALISTS NIL) (SETQ FOUNDCHANGE T] (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES) NIL]) ) (ADDTOVAR LISPXFNS (PUT . SAVEPUT) (PUTPROP . SAVEPUT)) (* ; "sub-functions for file package commands & types") (DEFINEQ (ALISTS.GETDEF [LAMBDA (NAME TYPE OPTIONS) (* Pavel " 7-Oct-86 17:24") (AND (LISTP NAME) (CL:SYMBOLP (CAR NAME)) (LET [(ASSOCIATION (ASSOC (CADR NAME) (GETTOPVAL (CAR NAME] (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME) ASSOCIATION]) (ALISTS.WHENCHANGED [LAMBDA (NAME TYPE NEWFLG) (* lmm "16-OCT-78 20:02") (* ;  "called by MARKASCHANGED when an ALIST entry has changed") (PROG [(VARTYPE (GETPROP (CAR NAME) 'VARTYPE] (AND (LISTP VARTYPE) (EQ (CAR VARTYPE) 'ALIST) (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME) (CADR VARTYPE) NEWFLG]) (CLEARCLISPARRAY [LAMBDA (NAME TYPE REASON) (DECLARE (SPECVARS NAME TYPE REASON)) (* lmm "14-Aug-84 15:03") (AND CLISPARRAY (MAPHASH CLISPARRAY (COND [(EQ TYPE 'I.S.OPRS) (FUNCTION (LAMBDA (TRAN FORM) (AND (MEMB NAME FORM) (PUTHASH FORM NIL CLISPARRAY] (T (* ; "MACRO changed") (FUNCTION (LAMBDA (TRAN FORM) (COND ((OR (EQ NAME (CAR FORM)) (EQ (CAR (GETPROP (CAR FORM) 'CLISPWORD)) 'CHANGETRAN)) (PUTHASH FORM NIL CLISPARRAY]) (EXPRESSIONS.WHENCHANGED [LAMBDA (EXPR) (* ; "Edited 6-Apr-87 20:21 by Pavel") (SELECTQ (CAR EXPR) ((SETQ SETQQ) (UNMARKASCHANGED (CADR EXPR) 'VARS)) ((PROGN PROG) (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X))) NIL]) (MAKEALISTCOMS [NLAMBDA X (* rmk%: "14-OCT-83 13:34") (* ;; "make command to dump prettydefmacros") (LIST (CONS 'ADDVARS (for PR in X join (for ALISTNAME inside (CAR PR) collect (CONS ALISTNAME (for ATNAME inside (CDR PR) bind ENTRY when (SETQ ENTRY (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME)) (PROGN (LISPXPRINT (LIST 'no ATNAME 'entry 'on ALISTNAME) T T) NIL))) collect ENTRY]) (MAKEFILESCOMS [NLAMBDA FILES (* JonL "12-FEB-83 19:02") (* ;; "This scans the command just to warn the user about any errors. Must match up with the big SELECTQ in FILESLOAD NIL") [for FILE in FILES do (OR (LITATOM FILE) (while (LISTP FILE) do (SELECTQ (CAR (OR (LISTP FILE) (RETURN))) ((LOADCOMP LOADFROM)) (FROM (pop FILE) (if (OR (EQ (CAR FILE) 'VALUEOF) (if (AND (EQ (CAR FILE) 'VALUE) (EQ (CADR FILE) 'OF)) then (pop FILE))) then (pop FILE))) ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR)) (OR (FMEMB (CAR FILE) LOADOPTIONS) (PRINT (CONS (CAR FILE) '(-- unrecognized FILES option)) T))) (pop FILE] (CONS 'FILESLOAD FILES]) (MAKELISPXMACROSCOMS [NLAMBDA X (* lmm " 5-SEP-78 23:15") (PROG (TEM TEM2) (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X (FUNCTION (LAMBDA (Z) (FASSOC Z LISPXHISTORYMACROS ] (LIST (CONS 'LISPXHISTORYMACROS TEM))) (AND [SETQ TEM (SUBSET X (FUNCTION (LAMBDA (Z) (FASSOC Z LISPXMACROS ] (LIST (CONS 'LISPXMACROS TEM] (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z) (FMEMB Z LISPXCOMS] (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2] (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z) (FMEMB Z HISTORYCOMS] (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2]) (MAKEPROPSCOMS [NLAMBDA X (* lmm "26-FEB-78 17:10") (* ;; "make command to dump PROPS") (for PAIR in X collect (CONS 'PROP (CONS (COND ((AND (LISTP (CDR PAIR)) (NULL (CDDR PAIR))) (CADR PAIR)) (T (CDR PAIR))) (OR (LISTP (CAR PAIR)) (LIST (CAR PAIR]) (MAKEUSERMACROSCOMS [NLAMBDA X (* rmk%: " 3-JAN-82 23:20") (PROG (TEM) [COND [X (for Y in X do (OR (FASSOC Y USERMACROS) (FASSOC Y EDITMACROS) (LISPXPRINT (CONS Y '(-- no entry on USERMACROS)) T T] (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR)) X] (RETURN (LIST (CONS 'ADDVARS (NCONC (for VAR in '(USERMACROS EDITMACROS) when (SETQ TEM (for Y in (GETTOPVAL VAR) when (FMEMB (CAR Y) X) collect Y)) collect (CONS VAR TEM)) (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS DONTSAVEHISTORYCOMS) when [SETQ TEM (SUBSET (GETTOPVAL LST) (FUNCTION (LAMBDA (Y) (OR (FMEMB Y X) (AND (LISTP Y) (FMEMB (CAR Y) X] collect (CONS LST TEM]) (PROPS.WHENCHANGED [LAMBDA (NAME TYPE NEWFLG) (* lmm " 7-SEP-78 22:08") (PROG [(PROPTYPE (GETPROP (CADR NAME) 'PROPTYPE] (COND [PROPTYPE (RETFROM 'MARKASCHANGED (COND ((NEQ PROPTYPE 'IGNORE) (MARKASCHANGED (CAR NAME) PROPTYPE NEWFLG] (T (SELECTQ (CADR NAME) (CLISPWORD (CLEARCLISPARRAY (CAR NAME))) NIL]) (FILEGETDEF.LISPXMACROS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:12") (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (EQ FIRST 'ADDTOVAR) (MEMB SECOND '(LISPXMACROS LISPXCOMS)) T] when (SELECTQ (CADR X) (LISPXMACROS (* ;  "Rebuild the expressions cause there might be other elements in the ADDTOVAR") (AND (SETQ X (ASSOC NAME (CDDR X))) (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X)))) (LISPXCOMS [COND ((MEMB NAME (CDDR X)) (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME))) ((SETQ X (ASSOC NAME (CDDR X))) (* ; "For synonym pairs") (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X]) NIL) collect X]) (FILEGETDEF.ALISTS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:13") (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (EQ FIRST 'ADDTOVAR) (EQ SECOND (CAR NAME] when (SETQ X (ASSOC (CADR NAME) (CDDR X))) collect X finally (RETURN (COND ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME) $$VAL]) (FILEGETDEF.RECORDS [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND) (* lmm "26-Jun-86 15:56") (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (MEMB FIRST CLISPRECORDTYPES) (OR (EQ SECOND NAME) (AND (MEMB SECOND '(%( %[)) (PROGN (RATOM) (RATOM) (RATOM) (EQ NAME (RATOM] (if (EQ (CAAR VAL) 'NOT-FOUND%:) then NOTFOUND elseif (CDR VAL) then (CONS 'PROGN VAL) else (CAR VAL]) (FILEGETDEF.PROPS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:13") (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (EQ FIRST 'PUTPROPS) (EQ SECOND (CAR NAME] join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL) (CADR NAME)) join (LIST (CAR TAIL) (CADR TAIL))) finally (RETURN (COND ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME) $$VAL]) (FILEGETDEF.MACROS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm "28-May-86 09:51") (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND) (AND (FMEMB FIRST '(PUTPROPS DEFMACRO)) (EQ SECOND NAME] join (if (EQ (CAR X) 'DEFMACRO) then (LIST X) else (for TAIL on (CDDR X) by (CDDR TAIL) when (FMEMB (CAR TAIL) MACROPROPS) collect (LIST 'PUTPROPS (CADR X) (CAR TAIL) (CADR TAIL]) (FILEGETDEF.VARS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm " 4-Jul-85 15:14") (for X in (LOADFNS NIL SOURCE 'GETDEF NAME) do (SELECTQ (CAR X) ((RPAQQ SETQQ) (RETURN (CADDR X))) ((RPAQ SETQ RPAQ?) (RETURN (EVAL (CADDR X)))) NIL) finally (RETURN 'NOBIND]) (FILEGETDEF.FNS [LAMBDA (NAME TYPE SOURCE OPTIONS) (* 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)) (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) (RETURN (WITH-READER-ENVIRONMENT ENV [COND ((EQMEMB 'ARGLIST OPTIONS) (RATOM SOURCE) (READ SOURCE) (RATOM SOURCE) (LIST (READ SOURCE) (READ SOURCE))) (T (CADR (READ SOURCE])] (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE]) (FILEPKGCOMS.PUTDEF [LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "15-Jul-85 11:29") (PROG (COM TYP) [SELECTQ (CAR (LISTP DEFINITION)) (COM (SETQ COM (CDR DEFINITION))) (TYPE (SETQ TYP (CDR DEFINITION))) (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION))) (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION] (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE") (for I in COM by (CDDR I) do (SELECTQ I ((ADD DELETE MACRO CONTENTS CONTAIN COM)) (ERROR I "not file package command property" ))) (* ;  "COM merely adds to spelling list, for builtins") [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS) (LISTGET COM 'CONTAIN] (* ; "Until CONTAIN is de-documented.") (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP (LISTGET COM PROP))) [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS) (SELECTQ I ((DESCRIPTION TYPE)) (ERROR I "not file package type/command property" ] (* ;  "TYPE merely adds to spelling list, for builtins") (for PROP in (UNION '(DESCRIPTION TYPE) FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP (LISTGET TYP PROP]) (FILES.PUTDEF [LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "15-Jul-85 17:13") (PROGN (PUTDEF (FILECOMS NAME) 'VARS (CAR DEFINITION) REASON) (* ; "DEFINE THE COMS") (ADDFILE NAME) (* ;  "MAKE SURE IT IS A FILE PACKAGE ENTITY") [/replace TOBEDUMPED of (fetch FILEPROP of NAME) (FILEPKG.MERGECHANGES (CADR DEFINITION) (fetch TOBEDUMPED of (fetch FILEPROP of NAME] (OR (fetch FILEDATES of NAME) (/replace FILEDATES of NAME with (CADDR DEFINITION]) (VARS.PUTDEF [LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "29-Jul-85 20:59") (/SETTOPVAL NAME DEFINITION T]) (FILES.WHENCHANGED [LAMBDA (NAME TYPE REASON) (MARKASCHANGED (FILECOMS NAME) 'VARS REASON]) ) (ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO) (ADDTOVAR SYSPROPS PROPTYPE) (PUTPROPS I.S.OPR PROPTYPE I.S.OPRS) (PUTPROPS SUBR PROPTYPE IGNORE) (PUTPROPS LIST PROPTYPE IGNORE) (PUTPROPS CODE PROPTYPE IGNORE) (PUTPROPS FILEDATES PROPTYPE IGNORE) (PUTPROPS FILE PROPTYPE IGNORE) (PUTPROPS FILEMAP PROPTYPE IGNORE) (PUTPROPS EXPR PROPTYPE FNS) (PUTPROPS VALUE PROPTYPE VARS) (PUTPROPS COPYRIGHT PROPTYPE FILES) (PUTPROPS FILETYPE PROPTYPE FILES) (PUTPROPS BAKTRACELST VARTYPE ALIST) (PUTPROPS BREAKMACROS VARTYPE ALIST) (PUTPROPS COMPILETYPELST VARTYPE ALIST) (PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS)) (PUTPROPS ERRORTYPELST VARTYPE ALIST) (PUTPROPS FONTDEFS VARTYPE ALIST) (PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS)) (PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS)) (PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS)) (PUTPROPS PRETTYEQUIVLST VARTYPE ALIST) (PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST) (PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST) (PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS)) (* ; "Define the commands below AFTER the various properties have been established.") (ADDTOVAR USERMACROS (M NIL (MAKE FILE FILE)) (M (X . Y) (E (MARKASCHANGED (COND ((LISTP 'X) (CAR 'X)) (T 'X)) 'USERMACROS) T) (ORIGINAL (M X . Y)))) (ADDTOVAR EDITMACROS (M (X . Y) (E (MARKASCHANGED (COND ((LISTP 'X) (CAR 'X)) (T 'X)) 'USERMACROS) T) (ORIGINAL (M X . Y)))) (ADDTOVAR EDITCOMSA M) (ADDTOVAR EDITCOMSL M) (* ; "GETDEF methods") (DEFINEQ (RENAME [LAMBDA (OLD NEW TYPES FILES METHOD) (* JonL "24-Jul-84 20:01") (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD))) (* ;; "special kludge: change the callers BEFORE if we are changing a field; this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message") [for TYPE inside TYPES when (NEQ TYPE 'FIELDS) do (COPYDEF OLD NEW TYPE NIL (COND ((EQ TYPE 'VARS) 'NOERROR] (CHANGECALLERS OLD NEW TYPES FILES METHOD) [for TYPE inside TYPES do (COND ((AND (EQ TYPE 'FIELDS) (HASDEF OLD 'FIELDS)) (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file. Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.") (COPYDEF OLD NEW 'FIELDS)) (T (DELDEF OLD TYPE] (RETURN NEW]) (CHANGECALLERS [LAMBDA (OLD NEW AS-TYPES FILES METHOD) (* ; "Edited 6-Dec-86 01:25 by lmm") (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES)) REL TEM EDITCOMS FNS) (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD)) [SETQ EDITCOMS (LIST (COND [(OR (EQMEMB 'CAREFUL METHOD) (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES)) (printout T "Warning --" OLD " is also defined as " TEM T))) (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename. Y means do it, No means skip, anything else goes into TTY.") (SUBPAIR '(OLD NEW) (LIST OLD NEW) '(BIND (LPQ (F OLD N) (MARK %#1) (ORR (1 !0 P) NIL) (MARK %#2) (COMS (SELECTQ (ASKUSER NIL NIL " Replace ? " '((Y "Yes ") (N "No ") (% "") (% "") (% "") (& "")) NIL NIL '(NOECHOFLG T)) (Y '(R1 OLD NEW)) (N NIL) 'TTY%:)) (MARK %#3) (IF (EQ (%## (\ %#3)) (%## (\ %#2))) ((\ %#1)) NIL] (T (LIST 'R OLD NEW] (SELECTQ (COND ((AND (EQMEMB 'MASTERSCOPE METHOD) MSDATABASELST (for TYPE inside AS-TYPES do [COND ((SETQ TEM (SELECTQ TYPE ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 'CALL) (MACROS '(CALL DIRECTLY)) ((VARS VARIABLES) '(USE OR BIND)) ((RECORDS FIELDS I.S.OPRS) (LIST 'USE 'AS TYPE)) (RETURN NIL))) (COND (REL (SETQ REL (LIST TEM 'OR REL))) (T (SETQ REL TEM] FINALLY (RETURN REL))) (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known") 'MASTERSCOPE) ((EQMEMB 'EDITCALLERS METHOD) 'EDITCALLERS) (T 'SEARCH)) (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND ((NULL FILES) (UPDATEFILES) (FILEPKGCHANGES 'FNS] (for FILE inside (OR FILES FILELST) join (FILEFNSLST FILE] (FUNCTION UPDATEFN)) (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL)) T) FNS))) (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST) when (SETQ TEM (EDITCALLERS OLD X T)) collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM))) X)))) (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST X)))) (ERROR "UNRECOGNIZED RENAME METHOD" METHOD)) (AND (EQMEMB 'FNS AS-TYPES) (FMEMB OLD FNS) (SETQ FNS (REMOVE OLD FNS))) (EDITFROMFILE FNS FILES OLD EDITCOMS) [for TYPE inside AS-TYPES do (for FILE in (WHEREIS OLD TYPE FILES) do (AND (ADDTOFILE NEW TYPE FILE) (DELFROMFILES OLD TYPE FILE) (printout T OLD " changed to " NEW " on " FILE))) (COND ((SETQ TEM (WHEREIS OLD TYPE FILES)) (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM] (COND (REL (UPDATECHANGED) (COND ((AND (SETQ TEM (GETRELATION OLD REL T)) (WHEREIS TEM 'FNS FILES)) (printout T "Couldn't find where " OLD " is referenced in " TEM T]) ) (DEFINEQ (SHOWDEF [LAMBDA (NAME TYPE FILE) (* ; "Edited 16-Apr-2018 21:35 by rmk:") (* ;  "prettyprint NAME as it would be dumped as a TYPE") (RESETLST (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP) (DECLARE (SPECVARS . T)) [AND FILE (NEQ FILE (OUTPUT)) (if (SETQ FL (OPENP FILE 'OUTPUT)) then (RESETSAVE (OUTPUT FL)) else (OUTFILE FILE) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (OUTPUT] (PRETTYCOM (MAKENEWCOM NAME TYPE))))]) (COPYDEF [LAMBDA (OLD NEW TYPE SOURCE OPTIONS) (* lmm "14-Aug-84 18:38") (* ; "like MOVD, but takes a type.") (PROG (TEM DEF) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) [SETQ DEF (GETDEF OLD TYPE SOURCE (COND ((EQ OPTIONS 'NOCOPY) NIL) (T (REMOVE 'NOCOPY (MKLIST OPTIONS] (* ;  "The default is for GETDEF to return a COPY. Make sure that NOCOPY isn't in options though.") (SELECTQ TYPE (VARS) (FILES [for X in (CAR DEF) do (* ;  "change all the listnames which are of form filenameTYPE") (SELECTQ (CAR X) ((PROP IFPROP) (SETQ X (CDR X))) NIL) (COND ((EQ (CADR X) '*) (SETQ X (CDDR X)) (COND ((AND (LITATOM (CAR X)) (SETQ TEM (STRPOS OLD (CAR X) 1 NIL T T))) (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X) TEM -1))) (COPY (GETTOPVAL (CAR X))) T) (FRPLACA X TEM]) ((PROPS ALISTS) (OR (EQ (CAR NEW) (CAR OLD)) (DSUBST (CAR NEW) (CAR OLD) DEF)) (OR (EQ (CADR NEW) (CADR OLD)) (DSUBST (CADR NEW) (CADR OLD) DEF))) (DSUBST NEW OLD DEF)) (PUTDEF NEW TYPE DEF) (RETURN NEW]) (GETDEF [LAMBDA (NAME TYPE SOURCE OPTIONS) (* lmm "13-Jul-85 04:10") (* ;; "returns the definition of NAME as a TYPE from SOURCE; cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found. The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.") (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS))) (DECLARE (SPECVARS NOCOPY)) (SELECTQ OPTIONS (0 (SETQQ OPTIONS (NOERROR NODWIM)) (SETQ NOCOPY T)) (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST)) (SETQ NOCOPY T)) (T (SETQQ OPTIONS SPELL)) NIL) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (SELECTQ SOURCE (0 (SETQQ SOURCE CURRENT)) (T (SETQQ SOURCE SAVED)) (NIL (SETQQ SOURCE ?)) NIL) [SELECTQ SOURCE (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS))) (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS] (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR)) (fetch NULLDEF of TYPE)) (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR)) (fetch NULLDEF of TYPE)) (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS]) (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS))) (COND ((AND (LISTP SOURCE) (EQ (CAR SOURCE) '=)) (SETQ DEF (CDR SOURCE))) (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS)) (SETQ NOCOPY T] (OR NOCOPY (SETQ DEF (COPY DEF))) (COND ((AND (EQ TYPE 'FNS) (NOT (EQMEMB 'NODWIM OPTIONS))) (DWIMDEF DEF NAME SOURCE))) (RETURN DEF]) (GETDEFCOM [LAMBDA (X) (* lmm " 4-Jul-85 13:31") (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in. Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed. --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion. That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.") (* ; "a RETFROM point") (for Y in X join (GETDEFCOM0 Y]) (GETDEFCOM0 [LAMBDA (COM) (* wt%: " 7-FEB-79 23:28") (PROG (TEM) (RETURN (COND ((SETQ TEM (fetch MACRO of (CAR COM))) (* COND ((fetch CONTENTS of  (CAR COM)) (* ;  "if it has a CONTENTS function, generally means it is not safe to evaluate")  (RETFROM (QUOTE GETDEFCOM)))) (for Y in (SUBPAIR (CAR TEM) (PRETTYCOM1 COM) (CDR TEM)) join (GETDEFCOM0 Y))) (T (SELECTQ (CAR COM) (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X))) (ADDVARS (for Y in (PRETTYCOM1 COM) collect (CONS 'ADDTOVAR Y))) (APPENDVARS (for Y in (PRETTYCOM1 COM) collect (CONS 'APPENDTOVAR Y))) (P (APPEND (PRETTYCOM1 COM))) (RETFROM 'GETDEFCOM]) (GETDEFCURRENT [LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 2-May-87 19:00 by Pavel") (* ;  "Gets the current definition--source=0") (LET (DEF) (COND ((AND (SETQ DEF (fetch GETDEF of TYPE)) (NEQ DEF T)) (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.") (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS)) (fetch NULLDEF of TYPE)) (GETDEFERR NAME TYPE OPTIONS)) DEF) (T (OR (NEQ [SETQ DEF (SELECTQ TYPE (FNS (AND (LITATOM NAME) (EXPRP (SETQ DEF (VIRGINFN NAME))) DEF)) (VARS (if (LITATOM NAME) then (GETTOPVAL NAME) else 'NOBIND)) ((FIELDS RECORDS) (if (LITATOM NAME) then [SETQ DEF (SELECTQ TYPE (RECORDS (RECLOOK NAME)) (MKPROGN (FIELDLOOK NAME] (if (EQMEMB 'EDIT OPTIONS) then (COPY DEF) else DEF))) (FILES (* ;  "what is the `definition' of a file? -- I guess the COMS which say what it contains") [if (LITATOM NAME) then (if (SETQ DEF (GETFILEDEF NAME)) then (UPDATEFILES) (LIST (LISTP (GETTOPVAL (FILECOMS DEF))) (fetch TOBEDUMPED of (fetch FILEPROP of DEF)) (LISTP (fetch FILEDATES of DEF]) (TEMPLATES (if (AND (LITATOM NAME) (SETQ DEF (GETTEMPLATE NAME))) then (LIST 'SETTEMPLATE (KWOTE NAME) (KWOTE DEF)))) (MACROS [if [AND (LITATOM NAME) (SETQ DEF (for X on (GETPROPLIST NAME) by (CDDR X) when (FMEMB (CAR X) MACROPROPS) join (LIST (CAR X) (CADR X] then `(PUTPROPS ,NAME ,@DEF]) (EXPRESSIONS (LISTP NAME)) (PROPS [AND (LISTP NAME) (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME)) [FUNCTION (LAMBDA (X) (EQ X (CADR NAME] (FUNCTION CDDR))) (LIST 'PUTPROPS (CAR NAME) (CADR NAME) (CADR DEF]) (FILEPKGCOMS [AND (LITATOM NAME) (PROG ((COM (FILEPKGCOM NAME)) (TYP (FILEPKGTYPE NAME))) (RETURN (COND ((AND COM TYP) (LIST (CONS 'COM COM) (CONS 'TYPE TYP))) (COM (LIST (CONS 'COM COM))) (TYP (LIST (CONS 'TYPE TYP]) (FILEVARS (COND ((AND (LITATOM NAME) (LISTP (SETQ DEF (GETTOPVAL NAME))) (WHEREIS NAME 'FILEVARS)) DEF) (T 'NOBIND))) (LET ((COMS (LIST (MAKENEWCOM NAME TYPE))) FILE) [COND ((NOT (SETQ DEF (GETDEFCOM COMS))) (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (RESETLST (RESETSAVE PRETTYFLG) (RESETSAVE FONTCHANGEFLG) [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH] (PRETTYDEFCOMS COMS) (SETFILEPTR FILE 0) [SETQ DEF (for X in (READFILE FILE) join (SELECTQ (CAR X) ((*) NIL) (DECLARE%: (for Y on (CDR X) unless (SELECTQ (CAR Y) ((COPYWHEN EVAL@LOADWHEN EVAL@COMPILEWHEN) (RETURN (LIST Y))) (FMEMB (CAR Y) DECLARETAGSLST)) collect (CAR Y))) (CL:EVAL-WHEN (CDDR X)) (PROGN (CDR X)) (LIST X] (SETQ NOCOPY T)))] (MKPROGN DEF] (fetch NULLDEF of TYPE)) (GETDEFERR NAME TYPE OPTIONS)) DEF]) (GETDEFERR [LAMBDA (NAME TYPE OPTIONS MSG) (* lmm "13-Jul-85 04:11") (DECLARE (USEDFREE NODEF)) (* ;  "Message non-null if looking for saved or filed definition.") (PROG (TEM) (RETURN (COND ((EQMEMB 'NOERROR OPTIONS) (* ;  "We want to do the string search in the HASDEF case") (RETURN (fetch NULLDEF of TYPE))) [(AND (NULL MSG) (EQMEMB 'SPELL OPTIONS) (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS) 'SPELL) T))) (NEQ TEM NAME)) (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS] (T (for O inside OPTIONS when (STRINGP O) do (RETFROM 'GETDEF O) finally (ERROR NAME (CONS TYPE '(definition not found)) T]) (GETDEFFROMFILE [LAMBDA (NAME TYPE SOURCE OPTIONS) (* bvm%: " 1-Oct-86 22:10") (* ;; "Tries to get definition from source file. If successful, returns the definition. Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.") (DECLARE (SPECVARS NAME)) (bind (NOTFOUND _ "not found") DEF SOURCE TEM2 for FILE inside (COND ((EQ SOURCE 'FILE) (WHEREIS NAME TYPE T)) (T SOURCE)) when (AND (SETQ SOURCE (FINDFILE FILE T)) (NEQ [SETQ DEF (COND ((SETQ TEM2 (fetch FILEGETDEF of TYPE)) (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND)) (T (SELECTQ TYPE (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND)) ((VARS FILEVARS) (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND)) (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND)) (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND)) (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND)) (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND)) (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND)) (COND [(SETQ DEF (GET TYPE 'DEFINERS)) (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF `(LAMBDA (FIRST SECOND) (AND (MEMB FIRST ',DEF) (OR (EQ SECOND NAME) (AND (MEMB SECOND '(%( %[)) (PROGN (RATOM) (RATOM) (RATOM) (EQ NAME (RATOM] (* ; "ick! Should use real closure") (if (EQ (CAAR VAL) 'NOT-FOUND) then NOTFOUND elseif (CDR VAL) then (CONS 'PROGN VAL) else (CAR VAL] (T (RESETLST (RESETSAVE (RESETUNDO)) [LET (LOAD-VERBOSE-STREAM) (DECLARE (SPECVARS LOAD-VERBOSE-STREAM)) (* ;  "just in case we get a PRETTYCOMPRINT in here") (LOADFNS NIL SOURCE 'PROP (COND ((LITATOM NAME) (* ;  "If an atom, only bother with expressions that contain it") (CONS (LIST '& '|..| NAME))) (T T] (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))] NOTFOUND)) do (AND (EQ SOURCE 'FILE) (OR (FMEMB FILE FILELST) (CL:FORMAT T "(from ~A)~%%" SOURCE))) (* ;  "Copying and dwimifying are done in GETDEF") (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS (APPEND '(no definition on) (MKLIST SOURCE]) (GETDEFSAVED [LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 11-Aug-87 18:14 by cutting") (* ;  "Gets the `saved' definition--source=T") (SELECTQ TYPE (FNS (OR (GETPROP NAME 'EXPR) (GETDEFERR NAME TYPE OPTIONS "no saved definition for"))) (VARS (* ;  "The value of a variable is never substituted into and never COPIED") (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X) 'VALUE) do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS "no saved value for ")))) (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS))) (GETDEFERR NAME TYPE OPTIONS "no saved definition for "]) (PUTDEF [LAMBDA (NAME TYPE DEFINITION REASON) (* ; "Edited 8-Apr-87 12:52 by Pavel") (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE))) (COND (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON)) (T (SELECTQ TYPE (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON)) (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON)) (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON)) (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON)) (EVAL DEFINITION)) NAME]) (EDITDEF [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (DECLARE (LOCALVARS . T) (SPECVARS SOURCE)) (* ; "Edited 27-Jul-87 11:04 by cutting") (* ;; "lets you edit anything. Given name and type, call editor on the definition (loading it in from SOURCE if necessary). If you change it, then the definition gets unsaved. OPTIONS is passed through from ED to the editor.") (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (COND ((AND (fetch EDITDEF of TYPE) (APPLY* (fetch EDITDEF of TYPE) NAME TYPE SOURCE EDITCOMS OPTIONS))) ((AND (EQ TYPE 'FNS) (NULL SOURCE)) (* ;  "special hack for EDITDEF of FNS because of ability to EDITLOADFNS") (EDITDEF.FNS NAME EDITCOMS OPTIONS)) (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS))) NAME]) (DEFAULT.EDITDEF [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (* ; "Edited 11-Jun-92 16:26 by cat") (PROG [(DEF (COND [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY] [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR] [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR] (T (LET ((FILES (WHEREIS NAME TYPE T))) (CL:IF (NULL FILES) (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE) [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME FILES) (CL:IF (CL:ENDP (CDR FILES)) (CL:IF (CL:Y-OR-N-P "Shall I load this file PROP? ") (CAR FILES)) (ASKUSER NIL NIL "indicate which file to load PROP: " (MAKEKEYLST FILES) T))] (CL:WHEN FILE (LOAD FILE 'PROP) (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])] (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.") (DECLARE (SPECVARS RETRY)) (* ;; "what is RETRY ???") (SETQ RETRY) (CL:WHEN DEF (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG) (* ;  "this function is called when there were changes made") (FIXEDITDATE DEF) (* ; "fix the edit date first - jtm") (PUTDEF NAME TYPE DEF) (MARKASCHANGED NAME TYPE 'CHANGED) (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition. doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here. this sometimes results in MARKASCHANGED getting called twice.") ] OPTIONS))]) (EDITDEF.FILES [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (* ; "Edited 18-Mar-87 16:07 by woz") (EDITDEF (FILECOMS NAME) 'VARS SOURCE EDITCOMS OPTIONS]) (LOADDEF [LAMBDA (NAME TYPE SOURCE) (* lmm "13-SEP-78 01:34") (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY]) (DWIMDEF [LAMBDA (DEF FN SOURCE) (* lmm " 6-Jun-86 17:23") (AND [OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (CADDR DEF)) 'CLISP%:) (SELECTQ SOURCE ((CURRENT SAVED FILE ?) NIL) (AND (LITATOM SOURCE) (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE] (LET ((NOSPELLFLG T) (DWIMESSGAG T) FILEPKGFLG LISPXHIST) (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST)) (DWIMIFY0 DEF (COND ((OR (LISTP FN) (NULL FN)) '?) (T FN)) NIL DEF]) (DELDEF [LAMBDA (NAME TYPE) (* ; "Edited 5-Dec-86 06:20 by lmm") (PROG (TEM) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) LP [COND ((SETQ TEM (fetch DELDEF of TYPE)) (APPLY* TEM NAME TYPE)) (T (SELECTQ TYPE (FNS (* ;  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such") (AND (EXPRP NAME) (/PUTD NAME)) (REMPROP NAME 'EXPR) [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME]) (VARS (/SETTOPVAL NAME 'NOBIND)) (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES) do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST] (/replace FILEPROP of NAME with NIL) (/replace FILECHANGES of NAME with NIL) (/replace FILEDATES of NAME with NIL) (FLUSHFILEMAPS NAME)) (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME) (DELFROMLIST 'FILEPKGTYPES NAME) (for FIELD on (FILEPKGCOM NAME) by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD) NIL)) (for FIELD on (FILEPKGTYPE NAME) by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD) NIL)) (/replace ALLFIELDS of NAME with NIL)) (ALISTS [AND (LISTP NAME) (DELFROMLIST (CAR NAME) (FASSOC (CADR NAME) (GETTOPVAL (CAR NAME]) (MACROS (for P in MACROPROPS do (/REMPROP NAME P))) (PROPS (AND (LISTP NAME) (/REMPROP (CAR NAME) (CADR NAME)))) (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS)) (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS )) (DELFROMLIST 'LISPXCOMS NAME) (DELFROMLIST 'HISTORYCOMS NAME)) (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet") T] (MARKASCHANGED NAME TYPE 'DELETED) (RETURN NAME]) (DELFROMLIST [LAMBDA (VAR VAL) (* rmk%: " 3-JAN-82 23:22") (AND (FMEMB VAL (GETTOPVAL VAR)) (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR) (FUNCTION (LAMBDA (X) (AND (NEQ X VAL) (OR (NLISTP X) (NEQ (CDR X) VAL]) (HASDEF [LAMBDA (NAME TYPE SOURCE SPELLFLG) (* ; "Edited 31-Aug-87 18:02 by drc:") (* ;; "is NAME the name of something of type TYPE? NIL SOURCE means 0, not ?") (DECLARE (SPECVARS TYPE)) (COND [[OR (LISTP TYPE) (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG") (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE)) (RETURN $$VAL] (T (PROG [(NODEF (fetch NULLDEF of TYPE)) (OPTS '(NODWIM NOCOPY NOERROR HASDEF] (COND ((NULL SOURCE) (SETQQ SOURCE CURRENT))) (RETURN (SELECTQ SOURCE ((CURRENT 0) [COND ([OR (MEMBER NAME (fetch CHANGED of TYPE)) (LET ((TM (fetch HASDEF of TYPE))) (COND (TM (APPLY* TM NAME TYPE SOURCE)) [(NOT (LITATOM NAME)) (SELECTQ TYPE (PROPS (AND (LISTP NAME) (GETPROP (CAR NAME) (CADR NAME)))) ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS FIELDS USERMACROS FILEVARS FILEPKGCOMS) NIL) (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS] (T (* ;; "symbol definitions") (SELECTQ TYPE (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS") "INTERLISP"))) (AND SYMBOL (BOUNDP SYMBOL)))) (TEMPLATES (GETTEMPLATE NAME)) (MACROS (GETLIS NAME MACROPROPS)) (LISPXMACROS (OR (FASSOC NAME LISPXMACROS) (FASSOC NAME LISPXHISTORYMACROS))) (VARS (AND (NOT (CL:KEYWORDP NAME)) (NEQ (GETTOPVAL NAME) 'NOBIND))) (RECORDS (RECLOOK NAME)) (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD] (RETURN (AND TEM (EQ (CAR TEM) 'FORWORD) (GETPROP (CDR TEM) 'I.S.OPR]) (FNS (AND (OR (AND (GETD NAME) (EXPRP (GETD NAME))) (GET NAME 'EXPR)) (NOT (HASDEF NAME 'FUNCTIONS SOURCE)))) (FIELDS (RECORDFIELD? NAME)) (USERMACROS (FASSOC NAME USERMACROS)) (FILEVARS) ((PROPS ALISTS DEFS EXPRESSIONS) NIL) (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST) (FMEMB NAME FILEPKGTYPES))) (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS] (OR NAME T)) (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME) (FIXSPELL NAME NIL (SELECTQ TYPE (FILES FILELST) (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES)) (FIELDS (for X in USERRECLST join (APPEND (RECORDFIELDNAMES X)))) (RECORDS (for X in USERRECLST when (LITATOM (CADR X)) collect (CADR X))) (LISPXMACROS LISPXCOMS) (I.S.OPRS I.S.OPRLST) (USERMACROS (MAPCAR USERMACROS (FUNCTION CAR))) USERWORDS) NIL (LISTP SPELLFLG) [FUNCTION (LAMBDA (X) (HASDEF X TYPE 'CURRENT] NIL T))]) (? (OR (HASDEF NAME TYPE 'CURRENT) (AND (LITATOM NAME) (HASDEF NAME TYPE 'SAVED SPELLFLG)) (WHEREIS NAME TYPE T))) ((SAVED T) (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS))) (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS]) (GETFILEDEF [LAMBDA (FILENAME) (* lmm " 4-Jul-85 13:25") (* ;;  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST") (COND ((FMEMB FILENAME FILELST) FILENAME) (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T) do (COND ((EQ (FILENAMEFIELD FILE 'NAME) FILENAME) (RETURN FILE]) (SAVEDEF [LAMBDA (NAME TYPE DEFINITION) (* JonL "24-Jul-84 20:11") (COND [(AND (LISTP NAME) (NULL TYPE)) (MAPCAR NAME (FUNCTION (LAMBDA (I) (SAVEDEF I 'FNS] (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME))) (/PUT NAME [SETQ TYPE (COND ((SUBRP DEFINITION) 'SUBR) ((EXPRP DEFINITION) 'EXPR) ((CCODEP DEFINITION) 'CODE) (T 'LIST] DEFINITION))) (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME))) 'NOBIND) (EQ DEFINITION (GETTOPVAL NAME)) (/PUT NAME (SETQ TYPE 'VALUE) DEFINITION))) (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT '(NOCOPY NOERROR NODWIM] (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS)) (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME)) SAVEDDEFS] TYPE]) (UNSAVEDEF [LAMBDA (NAME TYPE DEF) (* lmm " 6-Jun-86 17:24") (SELECTQ TYPE ((NIL EXPR CODE SUBR LIST) (COND [(LISTP NAME) (* ; "for compatibility") (MAPCAR NAME (FUNCTION (LAMBDA (X) (UNSAVED1 X TYPE] (T (UNSAVED1 NAME TYPE)))) (PROG NIL [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) 'SAVED 0)) (RETURN (CONS TYPE '(not found] (COND ((NEQ DFNFLG T) (SAVEDEF NAME TYPE) (LET ((DFNFLG T)) (PUTDEF NAME TYPE DEF))) (T (PUTDEF NAME TYPE DEF))) (RETURN TYPE]) (COMPAREDEFS [LAMBDA (NAME TYPE SOURCES) (* lmm " 4-Jul-85 14:37") (COND ((AND (LISTP TYPE) (GETFILEPKGTYPE SOURCES NIL T)) (swap TYPE SOURCES))) (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE)) (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T] [COND ((NULL SOURCES) (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE)) (SOME SRCS (FUNCTION (LAMBDA (FILE) (MEMBER NAME (CDR (ASSOC TYPE (fetch TOBEDUMPED of (fetch FILEPROP of FILE] (push SRCS 'CURRENT] (SETQ SRCS (for SRC in SRCS when (COND ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY] (fetch NULLDEF of TYPE)) (OR [SOME DEFS (FUNCTION (LAMBDA (DP) (COMPARELST DEF (CDR DP] (push DEFS (CONS SRC DEF))) T) (T (PRINTOUT T "No " SRC " definition found for " NAME T) NIL)) collect SRC)) (RETURN (COND ((NULL SRCS) '(no definitions found)) ((NULL (CDR SRCS)) '(only one definition found)) ((CDR DEFS) [for S1 on (DREVERSE DEFS) do (for S2 on (CDR S1) do (PRIN2 NAME T T) (AND (CAAR S1) (PRIN1 " from " T) (PRIN2 (CAAR S1) T T)) (PRIN1 " and " T) (PRIN2 NAME T T) (COND ((CAAR S2) (PRIN1 " from " T) (PRIN2 (CAAR S2) T T))) (PRIN1 " differ:" T) (TERPRI T) (COMPARELISTS (CDAR S1) (CDAR S2] 'DIFFERENT) (T 'SAME]) (COMPARE [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2) (* lmm " 5-SEP-78 13:37") (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY] (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY] (COND ((COMPARELST DEF1 DEF2) (RETURN))) (PRIN2 NAME1 T T) (COND (SOURCE1 (PRIN1 " from " T) (PRIN2 SOURCE1 T T))) (PRIN1 " and " T) (PRIN2 NAME2 T T) (COND (SOURCE2 (PRIN1 " from " T) (PRIN2 SOURCE2 T T))) (PRIN1 " differ:" T) (TERPRI T) (COMPARELISTS DEF1 DEF2) (RETURN T]) (TYPESOF [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER) (* ; "Edited 2-Aug-88 02:08 by masinter") (* ;; "return list of all known types which NAME names") (LET (FOUND SHADOWED) (if (FMEMB SOURCE '(? NIL)) then (CL:FLET [(RSHADOW NIL (for X in FOUND do (for Y in (CDR (FASSOC X SHADOW-TYPES)) do (if (FMEMB Y FOUND) then (* ; "shadower found before shadowed") (SETQ FOUND (REMOVE Y FOUND] (LET (NOTFOUND NEWTYPES) (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES) when [AND (LITATOM TYPE) (NOT (EQMEMB TYPE IMPOSSIBLETYPES)) (OR (NULL FILTER) (CL:FUNCALL FILTER TYPE)) (NOT (find X in FOUND suchthat (FMEMB TYPE (CDR (FASSOC X SHADOW-TYPES] do (if [OR (HASDEF NAME TYPE 'CURRENT) (AND (LITATOM NAME) (HASDEF NAME TYPE 'SAVED] then (push FOUND TYPE) else (push NOTFOUND TYPE))) (RSHADOW) [for FILE in FILELST while NOTFOUND when [NEQ T (fetch LOADTYPE of (GETPROP FILE 'FILE] do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND (FILECOMS FILE) 'TYPESOF)) then [bind X for TYPE in NEWTYPES when (FMEMB TYPE NOTFOUND) do (push FOUND TYPE) (if (SETQ X (FASSOC TYPE SHADOW-TYPES)) then (SETQ NOTFOUND (LDIFFERENCE NOTFOUND X)) else (SETQ NOTFOUND (REMOVE TYPE NOTFOUND] (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES] (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF)) then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND)) (SETQ FOUND (UNION NEWTYPES FOUND))) (RSHADOW) FOUND)) else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES) when (AND (LITATOM TYPE) (NOT (EQMEMB TYPE IMPOSSIBLETYPES)) (OR (NULL FILTER) (CL:FUNCALL FILTER TYPE)) (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE))) FOUND]) ) (RPAQ? WHEREIS.HASH ) (* ; "Must come after PUTDEF") (DEFINEQ (FIXEDITDATE [LAMBDA (EXPR) (* ; "Edited 17-Jul-89 11:13 by jtm:") (* NOBIND "18-JUL-78 21:11") (* Inserts or replaces previous edit  date) (AND INITIALS (LISTP EXPR) (LISTP (CDR EXPR)) (PROG (E) (COND ((FMEMB (CAR EXPR) LAMBDASPLST) (* ;; "insert the edit date after the argument list") (SETQ E (CDDR EXPR))) [(FMEMB (GETPROP (CAR EXPR) ':DEFINER-FOR) EDITDATE-ARGLIST-DEFINERS) (* ;; "insert the edit date after the argument list") (SETQ E (CDDR EXPR)) (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E)) finally (SETQ E (CDR E] ((FMEMB (GETPROP (CAR EXPR) ':DEFINER-FOR) EDITDATE-NAME-DEFINERS) (* ;; "insert the edit date after the name") (SETQ E (CDDR EXPR))) (T (RETURN))) RETRY [COND ((NLISTP E) (RETURN)) ((LISTP (CAR E)) (SELECTQ (CAAR E) ((CLISP%: DECLARE) (SETQ E (CDR E)) (GO RETRY)) (BREAK1 (COND ((EQ (CAR (CADAR E)) 'PROGN) (SETQ E (CDR (CADAR E))) (GO RETRY)))) (ADV-PROG (* No easy way to mark cleanly the  date of an advised function) (RETURN)) (COND ((AND (EQ (CAAR E) COMMENTFLG) (EQ (CADAR E) 'DECLARATIONS%:)) (SETQ E (CDR E)) (GO RETRY] (COND ([for TAIL on E while (AND (LISTP (CAR TAIL)) (EQ (CAAR TAIL) COMMENTFLG)) do (COND ((AND (LISTP (CDR TAIL)) (EDITDATE? (CAR TAIL))) (/RPLACA TAIL (EDITDATE (CAR TAIL) INITIALS)) (RETURN T] (* scans the comments for a  timestamp for this user.) NIL) (T (* attach the new timestamp at the  beginning of the comments.) (/ATTACH (EDITDATE NIL INITIALS) E))) (RETURN EXPR]) (EDITDATE? [LAMBDA (COMMENT) (* ; "Edited 11-Jun-92 16:44 by cat") (* ; "Edited 13-Jul-89 09:30 by jtm:") (* lmm "21-Mar-85 08:45") (* Tests to see if a given common is in fact an edit date --  this has to be general enough to recognize the most comment comment forms while  specific enough to not recognize things that are not edit dates) (DECLARE (LOCALVARS . T)) (* jtm%: changed test so that it  creates one timestamp per user.) (COND [(LISTP COMMENT) (COND ((EQ (CAR COMMENT) COMMENTFLG) [COND (NIL (NULL NORMALCOMMENTSFLG) (SETQ COMMENT (GETCOMMENT COMMENT] (COND ([OR (NOT (LISTP (CDR COMMENT))) (NOT (LISTP (CDDR COMMENT] NIL) [(EQ (CADR COMMENT) ';) (* ; "CL style comment") (STRPOS INITIALS (CADDR COMMENT) (IMINUS (NCHARS INITIALS] (T (* ; "IL style comment") (EQ (CADR COMMENT) INITIALS] ((STRINGP COMMENT]) ) (* ; "Edit date support for all kinds of definers (from PARC 6/10/92)") (RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES)) (RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS) ) (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started." ) (DEFINEQ (FILEPKGCOM [LAMBDA N (* JonL "10-Jul-84 19:38") (PROG (TEM (COM (ARG N 1))) (RETURN (COND [(EQ N 1) (OR (for FIELD in '(MACRO CONTENTS DELETE ADD) when (SETQ TEM (FILEPKGCOM COM FIELD)) join (LIST FIELD TEM)) (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST)) (LIST 'COM T)) (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST] (LIST 'COM TEM] ((EQ N 2) (SELECTQ (ARG N 2) (ADD (fetch ADD of COM)) (DELETE (fetch DELETE of COM)) (MACRO (fetch MACRO of COM)) ((CONTENTS CONTAIN) [OR (fetch (FILEPKGCOM CONTENTS) of COM) (COND ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM)) (COND ((EQ COM 'NILL) COM) [(EQ (CAR COM) 'LAMBDA) (CONS (CAR COM) (CONS [CONS (CAADR COM) (CONS (OR (CADDR (CADR COM)) 'NAME) (CONS (CADR (CADR COM)) (CDDDR (CADR COM] (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM] (T (LIST 'LAMBDA '(COM TYPE NAME) (CONS COM '(COM TYPE NAME]) (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST)) T) (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]) (ERROR (ARG N 2) "not file package command property"))) (T [for I TEM2 from 2 to N by 2 do (SETQ TEM (ARG N (ADD1 I))) (COND [(EQ (ARG N I) 'COM) (SELECTQ TEM (NIL) (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST)) (/SETTOPVAL 'FILEPKGCOMSPLST (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]) (COND ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST] (/RPLACD TEM2 TEM)) (T (/SETTOPVAL 'FILEPKGCOMSPLST (CONS (CONS COM TEM) (GETTOPVAL 'FILEPKGCOMSPLST] (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST)) (/SETTOPVAL 'FILEPKGCOMSPLST (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST] (SELECTQ (ARG N I) (ADD (/replace (FILEPKGCOM ADD) of COM with TEM)) (DELETE (/replace (FILEPKGCOM DELETE) of COM with TEM)) (MACRO (/replace (FILEPKGCOM MACRO) of COM with TEM)) ((CONTENTS CONTAIN) (/replace (FILEPKGCOM CONTENTS) of COM with TEM)) (ERROR (ARG N I) "not file package command property"] (MARKASCHANGED COM 'FILEPKGCOMS]) (FILEPKGTYPE [LAMBDA N (* lmm " 5-Jul-85 09:07") (PROG ((TYPE (ARG N 1)) TEM) (RETURN (COND [(EQ N 1) (OR (for FIELD in (UNION '(DESCRIPTION) FILEPKGTYPEPROPS) when (SETQ TEM (FILEPKGTYPE TYPE FIELD)) join (LIST FIELD TEM)) (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES)) (LIST 'TYPE T)) (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES] (LIST 'TYPE TEM] [(EQ N 2) (if (FMEMB (ARG N 2) FILEPKGTYPEPROPS) then (GETPROP TYPE (ARG N 2)) else (SELECTQ (ARG N 2) (DESCRIPTION (fetch DESCRIPTION of TYPE)) (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES)) T) (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]) (ERROR (ARG N 2) "not file package type property"] (T [for I TEM2 from 2 to N by 2 do (SETQ TEM (ARG N (ADD1 I))) (COND [(EQ (ARG N I) 'TYPE) (SELECTQ TEM (NIL) (T (OR (FMEMB TYPE FILEPKGTYPES) (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES)))) (COND ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES)) (/RPLACD TEM2 TEM)) (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM) FILEPKGTYPES] (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES) (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES ] (if (FMEMB (ARG N I) FILEPKGTYPEPROPS) then (if TEM then (/PUTPROP TYPE (ARG N I) TEM) else (/REMPROP TYPE (ARG N I))) else (SELECTQ (ARG N I) (DESCRIPTION (/replace DESCRIPTION of TYPE with TEM)) (ERROR (ARG N I) "not file package command/type property" ] (MARKASCHANGED TYPE 'FILEPKGCOMS]) ) (PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS))) (ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS) (ADDTOVAR FILEPKGTYPES FILEPKGCOMS) (PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE) (* Revert to NILL when no longer coercing PRETTYDEFMACROS to FILEPKGCOMS) (AND (EQ TYPE 'FILEPKGCOMS) (INFILECOMTAIL COM] (TYPE DESCRIPTION "file package commands/types" GETDEF T PUTDEF FILEPKGCOMS.PUTDEF))) (PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X] (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF WHENCHANGED (ALISTS.WHENCHANGED)))) (PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X]) (PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS))) (PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED ( EXPRESSIONS.WHENCHANGED ) EDITDEF NILL))) (PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL))) (PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS) (TYPE TYPE FILEPKGCOMS))) (PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X] CONTENTS (LAMBDA (COM NAME TYPE) (AND (EQ TYPE 'FILES) (SUBSET (INFILECOMTAIL COM) (FUNCTION LITATOM] (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED) EDITDEF EDITDEF.FILES))) (PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X))) (TYPE NULLDEF NOBIND EDITDEF NILL))) (PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO (X [E (MAPC 'X (FUNCTION (LAMBDA (FN) (AND (GETPROP FN 'FUNCTIONS) (CL:WARN "~A has a FUNCTIONS definition" FN] (ORIGINAL (FNS . X))) CONTENTS NILL) (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF T))) (PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X))) CONTENTS (LAMBDA (COM NAME TYPE ONFILETYPE) (AND (NULL ONFILETYPE) (EQ TYPE 'RECORDS) (INFILECOMTAIL COM]) (PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T))) (PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS))) (PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X))) CONTENTS NILL) (TYPE DESCRIPTION "LISPX commands"))) (PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM MACRO [X (DECLARE%: EVAL@COMPILE (P * (MAPCAR 'X (FUNCTION (LAMBDA (Y) (LET [[FNDEF (GETDEF Y 'FUNCTIONS 'CURRENT '(NOCOPY NOERROR] (MACDEF (GETDEF Y 'MACROS 'CURRENT '(NOCOPY NOERROR] (COND ((AND FNDEF (EQ (CAR FNDEF) 'DEFMACRO)) (CL:WARN "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S." FNDEF) (LIST 'PROGN FNDEF MACDEF)) (T (OR MACDEF (CL:CERROR "Go ahead and finish writing out the file." "No MACROS definition for ~A." Y) (GETDEF Y 'MACROS 'CURRENT] CONTENTS NILL) (TYPE DESCRIPTION "Interlisp macros" GETDEF MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY)))) (PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS))) (PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X] (TYPE DESCRIPTION "property lists" WHENCHANGED ( PROPS.WHENCHANGED )))) (PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM MACRO (X [E (MAPC 'X (FUNCTION (LAMBDA (RECORD) (AND (GETPROP RECORD 'STRUCTURES) (CL:WARN "~A has a STRUCTURES definition" RECORD] (E (RECORDECLARATIONS . X)) (INITRECORDS . X)) CONTENTS (LAMBDA (COM NAME TYPE ONFILETYPE) (AND (EQ TYPE 'FIELDS) (NULL ONFILETYPE) (MAPCONC (INFILECOMTAIL COM) (FUNCTION (LAMBDA (X) (APPEND ( RECORDFIELDNAMES X] (TYPE DESCRIPTION "records" DELDEF (LAMBDA (X) (/SETTOPVAL 'USERRECLST (REMOVE (RECLOOK X) USERRECLST]) (PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T))) (PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X))) CONTENTS (LAMBDA (COM NAME TYPE ONFILETYPE) (AND (NULL ONFILETYPE) (EQ TYPE 'RECORDS) (INFILECOMTAIL COM]) (PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X))) CONTENTS NILL) (TYPE DESCRIPTION "edit macros"))) (PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X [E (MAPC 'X (FUNCTION (LAMBDA (VAR) (AND (GETPROP VAR 'VARIABLES) (CL:WARN "~A also has a VARIABLES definition" VAR] (ORIGINAL (VARS . X))) CONTENTS NILL) (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF VARS.PUTDEF))) (PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL))) (PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X) (P (CONSTANTS . X]) (ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS) (VARIABLES VARS CONSTANTS)) (RPAQ? SAVEDDEFS ) (* ; "EDITCALLERS") (DEFINEQ (FINDCALLERS [LAMBDA (ATOMS FILES) (* lmm "30-SEP-78 01:36") (PROG ((X (EDITCALLERS ATOMS FILES T))) (RETURN (NCONC (DREVERSE (CDR X)) (AND (CAR X) (LIST (CONS (COND ((CDR X) '"plus other places on") (T 'on)) (CAR X]) (EDITCALLERS [LAMBDA (ATOMS FILES COMS) (* ; "Edited 8-Aug-2020 17:32 by rmk:") (* bvm%: " 3-Nov-86 17:30") (LET (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN) [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS] [for FILE in (COND ((NULL FILES) FILELST) ((EQ FILES T) (UNION SYSFILES FILELST)) ((LISTP FILES) FILES) (T (LIST FILES))) do (RESETLST [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I) (OR (SETQ FULL (FINDFILE FILE)) (RETURN (LISPXPRINT (CONS FILE '(not found)) T T))) [RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT] (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM))) (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP) (OR (GET-ENVIRONMENT-AND-FILEMAP FULL) (\PARSE-FILE-HEADER FILESTREAM))) (* ;; "Get reader environment of file. The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists. Otherwise, read the top of the file") (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV))) (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL)) [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS))) (push FFILEPOSPATTERNS (CONS RDTBL (SETQ PATTERNS (for ATOM in ATOMS collect (CONCAT (COND ((EQ (CHCON1 ATOM) (CHARCODE ESCAPE)) (SETQ ATOM (SUBSTRING ATOM 2 -1)) "") (T " ")) [COND ((SETQ I (STRPOS ' ATOM)) (SUBSTRING ATOM 1 (SUB1 I))) ((STRINGP ATOM)) (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE ATOM))) (* ;  "Keep MKSTRING from putting a prefix on") (MKSTRING ATOM T RDTBL] (COND (I "") (T " "] (for PATTERN in PATTERNS do (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0))) (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA)) do (COND ((NULL PRINTFLG) (* ;  "cause the printing of the filename to be saved on history list") (SETQ PRINTFLG T) (LISPXPRIN2 FULL T T T) (* ;; "print with NODOFLG=T means just to record the printing; the idea is that only those files in which something is found will be remembered on the history list") (LISPXPRIN1 ": " T NIL T))) [OR [AND (NEQ MAP T) (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0) (SETQ MAP (OR (GETFILEMAP FILESTREAM) (LOADFILEMAP FILESTREAM] (PROGN (* ; "file has no filemap") (SETQ MAP (SETQ NOMAPFLG T)) (LISPXPRIN1 " no filemap!" T) NIL))) thereis (AND (ILESSP (CAR X) I) (IGREATERP (CADR X) I) (for Z in (CDDR X) thereis (COND ((AND (ILESSP (CADR Z) I) (IGREATERP (CDDR Z) I)) [COND ((NOT (FMEMB (CAR Z) FNS)) (SETQ FNS (CONS (LISPXPRIN2 (CAR Z) T T) FNS] (SETQ I (CDDR Z)) T] (PROGN (LISPXPRIN2 I T T) (OR (FMEMB FILE OTHERSFILES) (SETQ OTHERSFILES (CONS FILE OTHERSFILES] (LISPXSPACES 1 T))) (COND (PRINTFLG (LISPXTERPRI T)) (T (TERPRI T))) (COND ((NEQ COMS T) (COND ((OR FNS OTHERSFILES) (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS)) FULL EDITPATTERN COMS (NULL OTHERSFILES)) (SETQ OTHERSFILES) (SETQ FNS])] (COND ((EQ COMS T) (CONS OTHERSFILES FNS]) (EDITFROMFILE [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES) (* rmk%: "14-Mar-85 21:51") (RESETVARS [(EDITLOADFNSFLG (COND ((EQ EDITLOADFNSFLG T) '(T . NO)) (T EDITLOADFNSFLG] (PROG NIL [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN] (AND (SETQ FILES (for FILE inside (OR FILES FILELST) when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE) FILELST)) (COND ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" FILE) NIL T)) (LOADFROM FILE FNS 'ALLPROP) T))) collect FILE)) (for TYPE in [COND ((LISTP ONLYTYPES)) (ONLYTYPES '(FNS)) (T (* ;; "Move FNS to the front. This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.") (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES] when (AND (LITATOM TYPE) (NEQ (fetch EDITDEF of TYPE) 'NILL)) do (PROG (SEEN) (for FILE inside FILES do (for NAME in [COND ((AND (EQ TYPE 'FNS) (NEQ FNS T)) (* ;  "for this type, we are given the list of items") (PROG1 FNS (SETQ FNS NIL))) (T (* ;  "only want the values of `TYPE' which are not part of some other type") (FILECOMSLST FILE TYPE 'EDIT] unless (MEMBER NAME SEEN) do (ERSETQ (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT '(NOCOPY NOERROR)) (GETDEF NAME TYPE 'SAVED '(NOCOPY NOERROR] (* ;; "If definition has been loaded, it may have been editted. Work on that explicitly instead of bringing in a file definition to smash the users previous changes. Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS. --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file. But ... rmk") (COND ((OR (AND (EQ TYPE 'FNS) (NEQ FNS T)) (AND (LISTP DEF) (LOOKIN DEF EDITPATTERN))) (COND ((NULL SEEN) (LISPXPRIN1 "editing the " T) (LISPXPRIN1 (OR (fetch DESCRIPTION of TYPE) TYPE) T) (LISPXSPACES 1 T))) (SETQ SEEN (CONS NAME SEEN)) (LISPXPRIN2 NAME T T) (LISPXPRIN1 ": " T) (COND ((NOT (ERSETQ (EDITDEF NAME TYPE (OR (AND DEF (CONS '= DEF)) FILE) EDITCOMS))) (LISPXPRIN1 "failed" T))) (LISPXTERPRI T]) (FINDATS [LAMBDA (X L) (* lmm "11-FEB-78 16:03") (COND ((NLISTP X) (FMEMB X L)) (T (OR (FINDATS (CAR X) L) (FINDATS (CDR X) L]) (LOOKIN [LAMBDA (X PAT) (* lmm "11-MAR-78 14:20") (COND ([AND (EQ (CAR PAT) '*ANY*) (EVERY (CDR PAT) (FUNCTION (LAMBDA (X) (AND (LITATOM X) (NOT (STRPOS ' X] (FINDATS X (CDR PAT))) (T (EDITFINDP X PAT T]) ) (DEFINEQ (SEPRCASE [LAMBDA (CLFLG RDTBL) (* bvm%: "24-Oct-86 18:16") (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent. Based on FILERDTBL, but others are close with respect to breaks and seprs") (OR RDTBL (SETQ RDTBL FILERDTBL)) (OR [ARRAYP (CDR (ASSOC RDTBL (COND (CLFLG CLISPCASEARRAYS) (T SEPRCASEARRAYS] (LET ((CA (CASEARRAY))) [if (READTABLEPROP RDTBL 'CASEINSENSITIVE) then (* ; "map upper into lower case") (for I from (CHARCODE A) to (CHARCODE Z) do (SETCASEARRAY CA I (+ I (- (CHARCODE a) (CHARCODE A] (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS collect (CHCON1 Y))) (GETSEPR RDTBL) (GETBRK RDTBL)) do (SETCASEARRAY CA X 0)) (if *PACKAGE* then (* ;  "symbols qualified with package prefix will otherwise be unfindable") (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR) 0)) (SETQ CA (CONS RDTBL CA)) (COND (CLFLG (push CLISPCASEARRAYS CA)) (T (push SEPRCASEARRAYS CA))) (CDR CA]) ) (RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL)) (RPAQ? SEPRCASEARRAYS ) (RPAQ? CLISPCASEARRAYS ) (MOVD? 'INFILEP 'FINDFILE) (* ; "or else from SPELLFILE") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG) (NOLINKFNS LOADFROM)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS) ) (* ; "EXPORT") (DEFINEQ (IMPORTFILE [LAMBDA (FILE RETURNFLG) (* lmm " 6-Jun-86 17:43") (RESETLST [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT] (RESETSAVE (INPUT FILE)) (* ;  "Reset INPUT in case some form on the file's action is to read the next expression") (NCONC [COND ((EQ RETURNFLG T) (* ;  "Just creating EXPORTS.ALL, don't side-effect the world") (IMPORTFILESCAN FILE RETURNFLG)) (T (LET (FILEPKGFLG DFNFLG) (IMPORTFILESCAN FILE RETURNFLG] (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE)) ''IMPORTDATE (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE] RETURNFLG)))]) (IMPORTEVAL [LAMBDA (FORM RETURNFLG) (* ; "Edited 2-May-87 18:57 by Pavel") (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms") (AND (LISTP FORM) (SELECTQ (CAR FORM) (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG))) (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG))) (/DECLAREDATATYPE (* ;  "Ignore datatype initializations -- we only need the record declaration itself") NIL) (PROGN (* ; "default: eval and/or return it") (AND (NEQ RETURNFLG T) (EVAL FORM)) (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))))]) (CHECKIMPORTS [LAMBDA (FILES NOASKFLG) (* rmk%: "19-FEB-83 16:31") (* ;  "Loads exported definitions from new versions of FILES.") (COND ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE when [AND (SETQ FULLFILENAME (FINDFILE FILE T)) (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE) 'IMPORTDATE] (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 'ICREATIONDATE] collect (LIST FILE FULLFILENAME))) (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from " (MAPCAR FILES (FUNCTION CAR))) '((Y "es ") (N "o ")) T) (N NIL) T))) (for FILE in FILES do (IMPORTFILE (CADR FILE]) (GATHEREXPORTS [LAMBDA (FROMFILES TOFILE FLG) (* bvm%: "14-Oct-86 23:12") (* ;  "Copies all exported definitions from FROMFILES to TOFILE.") (RESETLST [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE) (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT] (RESETSAVE (OUTPUT TOFILE)) (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*)) (SETQ ENV (if ENV then (\DO-DEFINE-FILE-INFO NIL ENV) else *OLD-INTERLISP-READ-ENVIRONMENT*)) (WITH-READER-ENVIRONMENT ENV (PRINT-READER-ENVIRONMENT ENV) (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T) " ON " (DATE) "%" T)" T "(LISPXTERPRI T)" T) (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T)) (FUNCTION PRINT)) (TERPRI)) (PRINT 'STOP) (TERPRI) (FULLNAME TOFILE))))]) (\DUMPEXPORTS [NLAMBDA COMS (* bvm%: "24-Oct-86 19:42") (* ;;; "Dumps an EXPORT form. IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.") (PRIN1 "(") (PRIN2 '*) (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2)) (* ;  "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE") (for TAIL on COMS do (PRETTYCOM (CAR TAIL))) (TERPRI) (PRINT ENDEXPORTDEFFORM) (TERPRI]) ) (PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X]) (RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")") (RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM) ) (* ; "for GAINSPACE") (DEFINEQ (CLEARFILEPKG [LAMBDA (FLG) (* bvm%: "29-Aug-86 13:02") (PROG NIL (COND ((SELECTQ FLG ((E T) T) (Y (TERPRI T) (PRIN1 "you can delete just the filemaps - " T) (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? " '((Y "es - everything" RETURN T) (N "o - just the filemaps" RETURN NIL) (E "verything" RETURN T) (F "ilemaps only" RETURN NIL] (TERPRI T))) NIL) (UPDATEFILES) [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE) (COND ((fetch TOBEDUMPED of (fetch FILEPROP of FILE)) (PRINT FILE T T) (PRIN1 " has changes, not wiped." T) (TERPRI T) T) (T (replace FILEPROP of FILE with NIL) (replace FILECHANGES of FILE with NIL) (SMASHFILECOMS FILE) (NCONC1 SYSFILES FILE) NIL] (SETQ LOADEDFILELST))) (SELECTQ FLG ((NIL T)) (CLRHASH *FILEMAP-HASH*]) ) (ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE) ((Y "es") (N "o") (E . "verything") (F "ilemaps only ")))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SMASHPROPSLST1) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T) (SPECVARS COMSNAME)) (BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM (NOLINKFNS . T) (SPECVARS COMSNAME) (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1)) (BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG) INFILECOMSPROP) (BLOCK%: NIL MAKEFILE (LOCALVARS . T) (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES)) (BLOCK%: ADDFILE ADDFILE ADDFILE0) (BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T)) (BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS) (LOCALVARS . T)) (BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T)) (BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE GETDEFSAVED (RETFNS GETDEFCOM) (NOLINKFNS . T) (GLOBALVARS NOT-FOUNDTAG)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS PRETTYDEFMACROS) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES) ) (PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1995 2018 2020 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (20677 22382 (SEARCHPRETTYTYPELST 20687 . 21666) (PRETTYDEFMACROS 21668 . 22126) ( FILEPKGCOMPROPS 22128 . 22380)) (23184 57307 (CLEANUP 23194 . 24582) (COMPILEFILES 24584 . 24860) ( COMPILEFILES0 24862 . 25582) (CONTINUEDIT 25584 . 27004) (MAKEFILE 27006 . 38648) (FILECHANGES 38650 . 40985) (FILEPKG.MERGECHANGES 40987 . 41810) (FILEPKG.CHANGEDFNS 41812 . 42124) (MAKEFILE1 42126 . 46353) (COMPILE-FILE? 46355 . 47912) (MAKEFILES 47914 . 49607) (ADDFILE 49609 . 52130) (ADDFILE0 52132 . 56268) (LISTFILES 56270 . 57305)) (57995 93235 (FILEPKGCHANGES 58005 . 59355) (GETFILEPKGTYPE 59357 . 62430) (MARKASCHANGED 62432 . 64069) (FILECOMS 64071 . 64455) (WHEREIS 64457 . 65877) ( SMASHFILECOMS 65879 . 66114) (FILEFNSLST 66116 . 66278) (FILECOMSLST 66280 . 66764) (UPDATEFILES 66766 . 72066) (INFILECOMS? 72068 . 73971) (INFILECOMTAIL 73973 . 75113) (INFILECOMS 75115 . 75276) ( INFILECOM 75278 . 85487) (INFILECOMSVALS 85489 . 85816) (INFILECOMSVAL 85818 . 86820) (INFILECOMSPROP 86822 . 87651) (IFCPROPS 87653 . 88914) (IFCEXPRTYPE 88916 . 89427) (IFCPROPSCAN 89429 . 90482) ( IFCDECLARE 90484 . 91795) (INFILEPAIRS 91797 . 92129) (INFILECOMSMACRO 92131 . 93233)) (93270 124046 ( FILES? 93280 . 95473) (FILES?1 95475 . 96125) (FILES?PRINTLST 96127 . 96909) (ADDTOFILES? 96911 . 107513) (ADDTOFILE 107515 . 108431) (WHATIS 108433 . 110409) (ADDTOCOMS 110411 . 112055) (ADDTOCOM 112057 . 118604) (ADDTOCOM1 118606 . 119777) (ADDNEWCOM 119779 . 120829) (MAKENEWCOM 120831 . 122674) (DEFAULTMAKENEWCOM 122676 . 124044)) (124116 126933 (MERGEINSERT 124126 . 126469) (MERGEINSERT1 126471 . 126931)) (127087 128444 (ADDTOFILEKEYLST 127097 . 128442)) (128561 139473 (DELFROMFILES 128571 . 129421) (DELFROMCOMS 129423 . 131102) (DELFROMCOM 131104 . 136972) (DELFROMCOM1 136974 . 137771) ( REMOVEITEM 137773 . 138647) (MOVETOFILE 138649 . 139471)) (139687 142056 (SAVEPUT 139697 . 142054)) ( 142181 150505 (UNMARKASCHANGED 142191 . 143899) (PREEDITFN 143901 . 146412) (POSTEDITPROPS 146414 . 148915) (POSTEDITALISTS 148917 . 150503)) (150654 171208 (ALISTS.GETDEF 150664 . 151043) ( ALISTS.WHENCHANGED 151045 . 151689) (CLEARCLISPARRAY 151691 . 152865) (EXPRESSIONS.WHENCHANGED 152867 . 153241) (MAKEALISTCOMS 153243 . 154316) (MAKEFILESCOMS 154318 . 155755) (MAKELISPXMACROSCOMS 155757 . 157775) (MAKEPROPSCOMS 157777 . 158475) (MAKEUSERMACROSCOMS 158477 . 160277) (PROPS.WHENCHANGED 160279 . 160900) (FILEGETDEF.LISPXMACROS 160902 . 162344) (FILEGETDEF.ALISTS 162346 . 162965) ( FILEGETDEF.RECORDS 162967 . 163898) (FILEGETDEF.PROPS 163900 . 164692) (FILEGETDEF.MACROS 164694 . 165754) (FILEGETDEF.VARS 165756 . 166172) (FILEGETDEF.FNS 166174 . 167538) (FILEPKGCOMS.PUTDEF 167540 . 169980) (FILES.PUTDEF 169982 . 170939) (VARS.PUTDEF 170941 . 171084) (FILES.WHENCHANGED 171086 . 171206)) (173230 180663 (RENAME 173240 . 174641) (CHANGECALLERS 174643 . 180661)) (180664 228612 ( SHOWDEF 180674 . 181467) (COPYDEF 181469 . 183943) (GETDEF 183945 . 186221) (GETDEFCOM 186223 . 187189 ) (GETDEFCOM0 187191 . 188537) (GETDEFCURRENT 188539 . 194959) (GETDEFERR 194961 . 196262) ( GETDEFFROMFILE 196264 . 200544) (GETDEFSAVED 200546 . 201650) (PUTDEF 201652 . 202355) (EDITDEF 202357 . 203334) (DEFAULT.EDITDEF 203336 . 206172) (EDITDEF.FILES 206174 . 206375) (LOADDEF 206377 . 206553) (DWIMDEF 206555 . 207409) (DELDEF 207411 . 210425) (DELFROMLIST 210427 . 210931) (HASDEF 210933 . 217255) (GETFILEDEF 217257 . 217779) (SAVEDEF 217781 . 219440) (UNSAVEDEF 219442 . 220338) ( COMPAREDEFS 220340 . 223642) (COMPARE 223644 . 224348) (TYPESOF 224350 . 228610)) (228679 233722 ( FIXEDITDATE 228689 . 232192) (EDITDATE? 232194 . 233720)) (234141 242727 (FILEPKGCOM 234151 . 239084) (FILEPKGTYPE 239086 . 242725)) (254764 269316 (FINDCALLERS 254774 . 255289) (EDITCALLERS 255291 . 262949) (EDITFROMFILE 262951 . 268631) (FINDATS 268633 . 268905) (LOOKIN 268907 . 269314)) (269317 271044 (SEPRCASE 269327 . 271042)) (271561 277103 (IMPORTFILE 271571 . 272545) (IMPORTEVAL 272547 . 273427) (IMPORTFILESCAN 273429 . 273850) (CHECKIMPORTS 273852 . 275188) (GATHEREXPORTS 275190 . 276513 ) (\DUMPEXPORTS 276515 . 277101)) (277441 279649 (CLEARFILEPKG 277451 . 279647))))) STOP \ No newline at end of file diff --git a/sources/FILEPKG.LCOM b/sources/FILEPKG.LCOM index c3d5a0d857fdc175b963d9a9542121d1889deabe..9d08805a73ac970c2f88e38c72535ab1ff02a2fe 100644 GIT binary patch delta 1565 zcmb7F&yU+w5bi5dC4N{cNI*!p)$l|r8+KQIFSZkVON!+<+bCIQYdfJW+C$j2nn+H( zO0tV8gmU0sQ3c6oPW=apmLvZH{|6FBE{HPrnylCDrH+*M=9`&szIpN+|MvXa@4sC8 zY40K9Tdm;REiQ8gtY$FHkTnV-J&Y#D<1jdaXbKd*Z+e{{?u?>I&-rUu>s7Gs znXYO1whO$bwM^_JHMz;w#DP z8o0LKcOBqLO5AF@d#&y+@Tv?qfO8eHx1KW{oStpn>!og42m8T(*K9kU@3x&?U`t(x zuYjp4R1R>Fp&|iOP-D+YNin3VA}2%UjFWLC$H|yd;H*_I1E?6Paur08QlKro<1igg z0t4@y{UE+`O5R;{VB0n`co9q>ZY;=0pQsvYILD~~Dyl!AprHEr`JAu~UPEoz55odUr}<-#A@x%101H=n=c{xIt6Kg4U6JxDGVtsv>nXoVhC$CwEPHV(M1i3 zo;<19lAb+z^oU-JUi<@0OuYI>c=O;_7z&el*~w(LxBdD)@AEwG`+oiSdiLF$*_VYL zzZBAH-4Gw)Bf!OlSVV|MF%Vp9HQIIC+JIIQFffnOM*hjwRmbW$sr%KoU2Ue6R;_BM z8rFtw?L@=zlwEh)wN}SUIj!wZ&2mzioFW(V*>IBMS&DHbB(^)WP=ppr2oX+*@)%xy zINf8chwY9N6rdpHWiN>XNh=g-5b~a`L!DA64C(+a1etBy24jbo=>i}9Lq8l2W7w#6 zDQO0eAMjBjz9{fZm}Q8EDCx3j%4xs@@x4j)l++Q$0>dZbkys3BTh->K0GP~bT`JcsR`mq_bcc%X>fbOQ;QW*v2 zZGA`D1g=0gDtCL(YJ$~gRDmBlS0RMxV9fH^!}Z!YO=JVWt1$KlpFS>D0QbRfTwB_ z856n`U1(Mt7K>pl5tzJuOYy{#InO0YQ!_cekjVlGvONf{@0&Bl*`X=agG0R^sbqB7 zT-8--Xj%tRH7c?`Fpn%#qpWI2pglOicNtpUE%%ELUG6dCbf>eW792hSBNqE4e%Iem znc5%8Bk1{|%VbFXu=yIfKu6)856vUSeeOeZ=RI2#(J;L&_n-*9Na$QGKr#vLUKs`H zhwsZM>Ha9Ai!_D`jlVkRtlOv{A7c7XE9mna2Vy#HY97c)`0=U??u6r28QqTfKVKC; cOMixXQ7n~Uv@oFNl>TD}B`%z#hxCE@1wU{aCjbBd